CSV 出力测试

最新推荐文章于 2024-04-23 23:23:32 发布
weixin_34405354
最新推荐文章于 2024-04-23 23:23:32 发布
阅读量93
点赞数
文章标签： shell
原文链接：http://www.cnblogs.com/yuzhengdong/p/3463950.html
版权
Public dic As Object '字典对象key：符合条件的excel的路径，value：对应的tag值

Private Declare Sub GetSystemTime Lib "kernel32" (lpSystemTime As SYSTEMTIME) '读取系统时间API
'* 自定义系统时间类型
Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type


Sub test()
    tt = Timer
    Dim csvFile$
    Application.ScreenUpdating = False
      Set dic = CreateObject("scripting.dictionary")
      
    setLog ("--------------开始出力----------------")
    Call FindFile("G:\CSV")
    arr = dic.keys
    For i = 0 To UBound(arr)
      csvFile = "c:\" & dic(arr(i)) & ".csv"
      Call getdata(arr(i), dic(arr(i)), csvFile)
    
    Next i
    
    Set dic = Nothing
    setLog ("--------------结束出力----------------")
    MsgBox Timer - tt
    Application.ScreenUpdating = True
End Sub

Function getit(ByVal filename As String) As String
    Dim f, shell, s As String, i As Long
    With CreateObject("scripting.filesystemobject")
        Set f = .GetFile(filename)
        Set shell = CreateObject("Shell.Application").Namespace(f.ParentFolder.Path)
        
           s = shell.GetDetailsOf(shell.Items.Item(f.Name), 18)
        
    End With
    getit = s
End Function
Function GetExcelTag(ByVal strPath As String) As Worksheet

    Set xlapp = CreateObject("excel.application")
    xlapp.Visible = False
    file1 = Dir(strPath & "")
    Do While file1 <> ""
        Set xlbook = xlapp.Workbooks.Open(strPath & file1)
        Debug.Print xlbook.BuiltinDocumentProperties("Keywords")
        xlbook.Close (True)
        file1 = Dir
    Loop
   ' Set xlbook = xlapp.Workbooks.Open(strPath)
   ' Set xlsheet = xlbook.Worksheets(1)
        

   ' xlbook.Close (True)
    xlapp.Quit
   ' Set xlsheet = Nothing
    Set xlbook = Nothing
    Set xlapp = Nothing


End Function

Public Sub FindFile(mPath As String, Optional sFile As String = "")

    Dim s As String, sDir() As String
    Dim i As Long, d As Long, morder$, csvFile$
    
    Set xlapp = CreateObject("excel.application")
    xlapp.Visible = False
    
  
    
    If Right(mPath, 1) <> "\" Then
        mPath = mPath & "\"
    End If
    '查找目录下的文件
    s = Dir(mPath & sFile, vbArchive + vbDirectory + vbNormal + vbReadOnly)
    Do While s <> ""
    
        If InStr(s, ".xlsx") > 0 Then
            Set xlbook = xlapp.Workbooks.Open(mPath & s)
            dic(mPath & s) = xlbook.BuiltinDocumentProperties("Keywords") 'getit(mPath & s)
            xlbook.Close (True)
        End If
           
       s = Dir
    Loop
    '查找目录下的子目录
    s = Dir(mPath, vbArchive + vbDirectory + vbNormal + vbReadOnly)
    Do While s <> ""
        If s <> "." And s <> ".." Then
            If (GetAttr(mPath & s) And vbDirectory) = vbDirectory Then
            d = d + 1
            ReDim Preserve sDir(d)
            sDir(d) = mPath & s
            End If
        End If
        s = Dir
    Loop
    
    xlapp.Quit
    Set xlbook = Nothing
    Set xlapp = Nothing
    
    '开始递归
    For i = 1 To d
        FindFile sDir(d) & "\"
    Next
        
End Sub


Function getdata(sPath As Variant, model As String, csvFilePath As Variant)
    Dim xlapp As Excel.Application
    Dim xlbook As Excel.Workbook
    Dim xlsheet As Excel.Worksheet
   
  With ActiveWorkbook.Sheets(model)
        filename = Mid(sPath, InStrRev(sPath, "\") + 1, Len(sPath) - InStrRev(sPath, "\") - 5) '把文件名提取出来
'--------------------------------------------------------------------------------

        If Dir(csvFilePath) = "" Then
              Open csvFilePath For Output As #1
                    Print #1, "filename," & Join(Application.Transpose(.Range("a2:a" & .[A65536].End(xlUp).Row)), ",")
              Close #1
        End If
'--------------------------------------------------------------------------------'如果还未生产csv文件则生成

        fieldNums = .[A65536].End(xlUp).Row
            
            '如果key存在1个以上的情况该怎么处理？
            
            
            'zyx = i '记录key所在cell的行
        For i = 2 To .[B65536].End(xlUp).Row
             If .Cells(i, 2).Value = "key" Then KeyValue = .Cells(i, 1).Value
        Next i
            
'--------------------------------------------------------------------------------'找到key
        
        
        Set xlapp = CreateObject("excel.application")
        xlapp.Visible = False
        Set xlbook = xlapp.Workbooks.Open(sPath)
        Set xlsheet = xlbook.Worksheets(1)
        Dim flag As Boolean, MoveFlag As Boolean, strRow$
'--------------------------------------------------------------------------------' 打开excel表开始读数据，优先找key
        
        MoveFlag = False
       
        If KeyValue <> "" Then
               xROW = xlsheet.Range(KeyValue).Row '记录key所在cell的行
               yColumn = xlsheet.Range(KeyValue).Column '记录key所在cell的列
            
               For xyz = xROW To xlsheet.Cells(65536, yColumn).End(xlUp).Row
                    If xlsheet.Cells(xyz, yColumn).Value <> "" Then
                        flag = True
                        strRow = strRow & filename & ","
                        '检查
                        For i = 2 To fieldNums
                        
                            If .Cells(i, 3).Value = "○" Then  '-----------------------------------------检查是必填项
                               
                                '如果是和key所在的行是一样的情况：检查的就是偏移行
                                If xlsheet.Range(.Cells(i, 1).Value).Row <> xROW Then
                                    If xlsheet.Range(.Cells(i, 1).Value) <> "" Then
                                        strRow = IIf(i = fieldNums, strRow & xlsheet.Range(.Cells(i, 1).Value), strRow & xlsheet.Range(.Cells(i, 1).Value) & ",")
                                    Else
                                        setLog ("【文件：" + filename + " | key值：" + xlsheet.Cells(xyz, yColumn).Value + " cell名称：" + .Cells(i, 1).Value + " （行：" + Str(xlsheet.Range(.Cells(i, 1).Value).Row) + " 列：" + Str(xlsheet.Range(.Cells(i, 1).Value).Column) + "）的值不能为空!】")
                                         'log出力
                                         flag = False
                                         MoveFlag = True
                                    End If
                                Else
                                    If xlsheet.Range(.Cells(i, 1).Value).Offset(xyz - xROW, 0) <> "" Then
                                        strRow = IIf(i = fieldNums, strRow & xlsheet.Range(.Cells(i, 1).Value).Offset(xyz - xROW, 0), strRow & xlsheet.Range(.Cells(i, 1).Value).Offset(xyz - xROW, 0) & ",")
                                    Else
                                        setLog ("【文件：" + filename + " | key值：" + xlsheet.Cells(xyz, yColumn).Value + " cell名称：" + .Cells(i, 1).Value + " （行：" + Str(xyz) + " 列：" + Str(xlsheet.Range(.Cells(i, 1).Value).Column) + "）的值不能为空!】")
                                         'log出力
                                         flag = False
                                         MoveFlag = True
                                    End If
                                
                                End If
                               
                               
                            Else            '不检查
                                strRow = IIf(i = fieldNums, strRow & xlsheet.Range(.Cells(i, 1).Value), strRow & xlsheet.Range(.Cells(i, 1).Value) & ",")
                            End If
      
                                 

                                 
                         Next i
 '------------------------------------------------------------------------------------------'出力到csv
                        If flag Then
                        
                           Open csvFilePath For Append As #2
                             Print #2, strRow
                           Close #2
                           setLog ("【文件：" + filename + " | Key值：" + xlsheet.Cells(xyz, yColumn).Value + " （行：" + Str(xyz) + " 列：" + Str(yColumn) + "）正常出力!】")
                           
                        End If
                         
                       
                         
                        
                    Else '-----------------------------------------------------------------------'出力log 表示为key的值不能为空’该条数据不出力
                    
                         setLog ("【文件：" + filename + " | （行：" + Str(xyz) + " 列：" + Str(yColumn) + "）Key值不能为空!】")
                         
                    End If
                    
                    strRow = "" '--------------------------------------------------------情况临时存放数据开始进行下一次的循环
               Next xyz
           
 

                    
               
        Else '---------------------------------------------------------------------------没有key的场合只跑一遍
            flag = True
             '----------------------------------------------------------------------------各项目检查
                 For i = 2 To fieldNums
        
                         If .Cells(i, 3).Value = "○" Then  '检查是必填项
                            If xlsheet.Range(.Cells(i, 1).Value) <> "" Then
                                strRow = strRow & xlsheet.Range(.Cells(i, 1).Value) & ","
                            Else
                                setLog ("【文件：" + filename + " | key值：" + xlsheet.Cells(xyz, yColumn).Value + " cell名称：" + .Cells(i, 1).Value + " （行：" + Str(xlsheet.Range(.Cells(i, 1).Value).Row) + " 列：" + Str(xlsheet.Range(.Cells(i, 1).Value).Column) + "）的值不能为空!】")
                            'log出力
                            flag = False
                            MoveFlag = True
                            End If
                         Else            '不检查
                            strRow = strRow & xlsheet.Range(.Cells(i, 1).Value) & ","
                         
                         End If
 
                 Next i
                 
                 If flag Then
                    '出力到csv
                    Open csvFilePath For Append As #2
                        Print #2, strRow
                    Close #2
                    setLog ("【文件：" + filename + " | Key值：" + xlsheet.Cells(xyz, yColumn).Value + " （行：" + Str(xyz) + " 列：" + Str(yColumn) + "）正常出力!】")
                    
                 End If
         
           
        
         End If
        
'------------------------------------------------------------------------------------------关闭打开的execl对象

        xlbook.Close (True)
        xlapp.Quit
        Set xlsheet = Nothing
        Set xlbook = Nothing
        Set xlapp = Nothing
    
    
    
    End With
  
    If MoveFlag Then
       '只要过程中友出现异常了，移动excel到指定文件夹
    End If
    
End Function

Private Sub setLog(strInput As Variant)

    Dim SysTime As SYSTEMTIME, logPath$, strReturn$
    GetSystemTime SysTime
    logPath = "c:\" + CStr(Year(Now)) + Format(Month(Now), "00") + Format(Day(Now), "00") + ".log"
    strReturn = CStr(Date) & "_" & CStr(Time) + " " + Format(CStr(SysTime.wMilliseconds), "000") + "　" & strInput '添加系统时间后的录入字符
    If Dir(logPath) = "" Then
        Open logPath For Output As #3
            Print #3, strReturn
         Close #3
    Else
         Open logPath For Append As #4
            Print #4, strReturn
         Close #4
    
    End If
    
End Sub


Sub gettest(wSheet As Worksheet)
    Debug.Print wSheet.[a1]
End Sub

Sub aatest()

    GetExcelTag ("G:\CSV\")

End Sub
转载于:https://www.cnblogs.com/yuzhengdong/p/3463950.html
weixin_34405354
关注
0
点赞
踩
0

收藏

觉得还不错? 一键收藏
0
评论
CSV 出力测试

Public dic As Object '字典对象key：符合条件的excel的路径，value：对应的tag值Private Declare Sub GetSystemTime Lib "kernel32" (lpSystemTime As SYSTEMTIME) '读取系统时间API'* 自定义系统时间类型Private Type SYSTEMTIME wYea...
复制链接

扫一扫