财务不同成本中心的表格（格式相同）内容汇总

先查找指定文件夹内所有excel文件，文件列表处理确定后，挨个打开文件，拷贝数据到指定表格；

'MuLu the folder to find files, as, "F:\VBA\pdf\Excel2007VBA"
'LeiXing the file type.if ignore, then this function will find folders; such as "*.*","*.PDF"
'LeiXing is set, 1.Zi is true, find documents in all the folders and subfolders; 2.Zi is false, find documents in Mulu
'LeiXing is empty, 1.Zi is true, find allthe subfolders 2.Zi is false find folders in Mulu
'the result of this function is a one-way array
Public Function ListFile(MuLu As String, Zi As Boolean, Optional LeiXing As String = "")
    Dim MyFile As String, ms As String
    Dim arr, brr, X
    Dim i, a As Integer
    Set d = CreateObject("Scripting.Dictionary")
    If Right(MuLu, 1) <> "\" Then MuLu = MuLu & "\"
    d.Add MuLu, ""
    i = 0
    On Error Resume Next
    Do While i < d.Count
        brr = d.keys
        MyFile = Dir(brr(i), vbDirectory)
        Do While MyFile <> ""
            If MyFile <> "." And MyFile <> ".." Then
                If (GetAttr(brr(i) & MyFile) And vbDirectory) = vbDirectory Then
                    If Err.Number = 0 Then
                        d.Add (brr(i) & MyFile & "\"), ""
                    ElseIf Err.Number = 52 Then
                    '    Debug.Print Err.Number
    '                    Debug.Print brr(i) & MyFile
                        Err.Clear
    '                    Resume Next
                    End If
                End If

            End If
            MyFile = Dir
        Loop
        If Zi = False Then Exit Do
        i = i + 1
    Loop
    On Error GoTo 0
    a = 2
    If LeiXing = "" Then
        ListFile = Application.Transpose(d.keys)
    Else
        For Each X In d.keys
            MyFile = Dir(X & LeiXing)
            Do While MyFile <> ""
                ActiveSheet.Cells(a, 2) = MyFile
                ActiveSheet.Cells(a, 3) = Left(MyFile, Len(MyFile) - 5)
                ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Cells(a, 2), Address:=X & MyFile, SubAddress:=""
                ms = ms & X & MyFile & "/"
                MyFile = Dir
                a = a + 1
            Loop
            If Zi = False Then Exit For
        Next
        If ms = "" Then ms = "No results found."
        ListFile = Application.Transpose(Split(ms, "/"))
    End If
End Function

Public Sub MakeFileList() 'run first
    Dim a
    Dim filePath As String
    Dim temPosition
    
    filePath = Parse_Resource("Y:\2022\03 Cost center planning\Dalian cost center") & "\"
    a = ListFile(filePath, True, "*.xlsx")
    Range("a2").Resize(UBound(a), 1) = a

End Sub

Sub CopyData() ' run when the excel files are found
    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    ' first use sub a to make the file list, then use this function
    Set wb1 = ActiveWorkbook
    Set ws1 = wb1.Worksheets("Sheet1")
    maxRow = ws1.Cells(1048576, 1).End(xlUp).Row
    temrow1 = 1
    temrow2 = 1
    temrow3 = 1
    
    ws1.Columns(4).ClearContents  'initialization
    wb1.Worksheets("Sheet2").Cells.Delete
    wb1.Worksheets("Sheet3").Cells.Delete
    wb1.Worksheets("Sheet4").Cells.Delete
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False 'set no alerts
    
    For i = 2 To maxRow
        DoEvents 'add as the programm crashed many times
        Set wb2 = Workbooks.Open(ws1.Cells(i, 1), False, ReadOnly:=False, notify:=False)
        temName = ws1.Cells(i, 2)
        For Each ws2 In wb2.Worksheets 'find the target sheets, copy all existed value
            With ws2
                If .Name = "traveling cost" Then
                   wb1.Worksheets("Sheet2").Cells(temrow1 + 1, 1) = ws1.Cells(i, 3)
                   maxRowSh = WorksheetFunction.Max(.Cells(1048576, 1).End(xlUp).Row, .Cells(1048576, 2).End(xlUp).Row, .Cells(1048576, 3).End(xlUp).Row, .Cells(1048576, 4).End(xlUp).Row, .Cells(1048576, 17).End(xlUp).Row)
                   .Range(.Cells(1, 1), .Cells(maxRowSh, 17)).Copy
                   wb1.Worksheets("Sheet2").Cells(temrow1 + 1, 2).PasteSpecial Paste:=xlPasteValues
                   temrow1 = temrow1 + maxRowSh
                End If
                If .Name = "Accruals" Then
                   wb1.Worksheets("Sheet3").Cells(temrow2 + 1, 1) = ws1.Cells(i, 3)
                   maxRowSh = WorksheetFunction.Max(.Cells(1048576, 1).End(xlUp).Row, .Cells(1048576, 2).End(xlUp).Row, .Cells(1048576, 3).End(xlUp).Row, .Cells(1048576, 4).End(xlUp).Row, .Cells(1048576, 18).End(xlUp).Row)
                   .Range(.Cells(1, 1), .Cells(maxRowSh, 18)).Copy
                   wb1.Worksheets("Sheet3").Cells(temrow2 + 1, 2).PasteSpecial Paste:=xlPasteValues
                   temrow2 = temrow2 + maxRowSh
                End If
                If .Name = "other miscellaneous cost" Then
                   wb1.Worksheets("Sheet4").Cells(temrow3 + 1, 1) = ws1.Cells(i, 3)
                   maxRowSh = WorksheetFunction.Max(.Cells(1048576, 1).End(xlUp).Row, .Cells(1048576, 2).End(xlUp).Row, .Cells(1048576, 3).End(xlUp).Row, .Cells(1048576, 4).End(xlUp).Row, .Cells(1048576, 17).End(xlUp).Row)
                   .Range(.Cells(1, 1), .Cells(maxRowSh, 17)).Copy
                   wb1.Worksheets("Sheet4").Cells(temrow3 + 1, 2).PasteSpecial Paste:=xlPasteValues
                   temrow3 = temrow3 + maxRowSh
                End If
            End With
        Next
        Application.CutCopyMode = False  'set no clipboard alert
        wb2.Close
        ws1.Cells(i, 4) = "OK"
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "OK"
End Sub
Public Function Parse_Resource(URL As String)
     'Uncomment the below line to test locally without calling the function & remove argument above
     'Dim URL As String
     Dim SplitURL() As String
     Dim i As Integer
     Dim WebDAVURI As String

    'Check for a double forward slash in the resource path. This will indicate a URL
     If Not InStr(1, URL, "//", vbBinaryCompare) = 0 Then

         'Split the URL into an array so it can be analyzed & reused
         SplitURL = Split(URL, "/", , vbBinaryCompare)

         'URL has been found so prep the WebDAVURI string
         WebDAVURI = "\\"

         'Check if the URL is secure
         If SplitURL(0) = "https:" Then
             'The code iterates through the array excluding unneeded components of the URL
             For i = 0 To UBound(SplitURL)
                 If Not SplitURL(i) = "" Then
                     Select Case i
                         Case 0
                             'Do nothing because we do not need the HTTPS element
                         Case 1
                             'Do nothing because this array slot is empty
                         Case 2
                         'This should be the root URL of the site. Add @ssl to the WebDAVURI
                             WebDAVURI = WebDAVURI & SplitURL(i) & "@ssl"
                         Case Else
                             'Append URI components and build string
                             WebDAVURI = WebDAVURI & "\" & SplitURL(i)
                     End Select
                 End If
             Next i

         Else
         'URL is not secure
             For i = 0 To UBound(SplitURL)

                'The code iterates through the array excluding unneeded components of the URL
                 If Not SplitURL(i) = "" Then
                     Select Case i
                         Case 0
                             'Do nothing because we do not need the HTTPS element
                         Case 1
                             'Do nothing because this array slot is empty
                             Case 2
                         'This should be the root URL of the site. Does not require an additional slash
                             WebDAVURI = WebDAVURI & SplitURL(i)
                         Case Else
                             'Append URI components and build string
                             WebDAVURI = WebDAVURI & "\" & SplitURL(i)
                     End Select
                 End If
             Next i
         End If
      'Set the Parse_Resource value to WebDAVURI
      Parse_Resource = WebDAVURI
     Else
     'There was no double forward slash so return system path as is
         Parse_Resource = URL
     End If
     Parse_Resource = WorksheetFunction.Substitute(Parse_Resource, "%20", " ")
 End Function
Function findPosition(findText As String, withinText As String, startPosition As Long, textCount As Long)
    'find the position of findText in the withinText;
    'startPosition is the start position in the withinText
    'textCount is the count of findText you want to find, if no then return 0
    'If textCount<=0, then find the last one of the findText in the withinText
    findPosition = 0
    If Len(WorksheetFunction.Substitute(withinText, findText, "")) = Len(withinText) Then
        Exit Function
    End If
    If textCount > 0 Then
        For i = 1 To textCount
            If startPosition > Len(withinText) Then
                findPosition = 0
                Exit For
            ElseIf IsError(WorksheetFunction.Find(findText, withinText, startPosition)) Then
                findPosition = 0
                Exit For
            ElseIf i = textCount Then
                findPosition = WorksheetFunction.Find(findText, withinText, startPosition)
            Else
                startPosition = WorksheetFunction.Find(findText, withinText, startPosition) + 1
            End If
        Next
    Else 'find the last one
        Do While startPosition <= Len(withinText)
            If IsError(WorksheetFunction.Find(findText, withinText, startPosition)) Then
                Exit Do
            Else
                findPosition = WorksheetFunction.Find(findText, withinText, startPosition)
                startPosition = findPostion + 1
            End If
        Loop
    End If
    'Debug.Print findPostion
End Function