Question

我想将数百个excel文件合并到一个文件中。问题是这些文件包含我不需要的数百列额外数据。更复杂的是，工作簿和工作簿之间的列位置不同，列数不同。我想创建一个宏，它将遍历并打开每个文件，搜索我需要的列，然后复制这些数据列并将它们组合成一个主文件。

以下代码的工作方式如下：将要合并的所有文件放在一个文件夹中键入要搜索的标头，并将这些文件合并到新工作簿中。

如果您的文件中有4列名为：名称日期产品和时间

然后在新工作表中的A1和B1中键入日期和时间将搜索所有文件，并将找到的任何列与匹配的标题组合到编译表中。

感谢Ron DeBruin对大多数文件系统的选择。

    'Option Explicit

    'takes worksheet and returns last row
    Private Function LastRowUsed(sh As Worksheet) As Long
        On Error Resume Next
        LastRowUsed = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        LookAt:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
        On Error GoTo 0
    End Function
    'takes worksheet and returns last column
    Private Function LastColUsed(sh As Worksheet) As Long
On Error Resume Next
LastColUsed = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        LookAt:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
        On Error GoTo 0
    End Function

    Function GetFileListArray() As String()
Dim fileDialogBox As FileDialog
Dim SelectedFolder As Variant
Dim MYPATH As String
Dim MYFILES() As String
Dim FILESINPATH
Dim FNUM, i As Integer

        '''''
        Set fileDialogBox = Application.FileDialog(msoFileDialogFolderPicker)

         'Use a With...End With block to reference the FileDialog object.
         With fileDialogBox
             If .Show = -1 Then 'the user chose a folder
         For Each SelectedFolder In .SelectedItems
            MYPATH = SelectedFolder 'asign mypath to the selected folder name
           ' MsgBox "The path is: " & SelectedFolder 'display folder selected
         Next SelectedFolder
         'The user pressed Cancel.
         Else
            MsgBox "Cancel was pressed or Invalid folder chosen, ending macro"
            Exit Function
         End If
         End With
         'Set the file dialog object variable to Nothing to clear memory
         Set fileDialogBox = Nothing
           If Right(MYPATH, 1) <> "\" Then
             MYPATH = MYPATH & "\"
           End If
        FILESINPATH = Dir(MYPATH & "*.csV")
        If FILESINPATH = "" Then
           MsgBox "No files found"
          Exit Function
        End If

        'Fill the array(myFiles)with the list of Excel files in the folder
        FNUM = 0
        Do While FILESINPATH <> ""
          FNUM = FNUM + 1
          ReDim Preserve MYFILES(1 To FNUM)
          MYFILES(FNUM) = FILESINPATH
          FILESINPATH = Dir()
        Loop


GetFileListArray = MYFILES()
End Function
    Sub RFSSearchThenCombine()
'search first worksheet in files opened, change to search other worksheets
Const SHEET_TO_SEARCH = 1

Dim FileList() As String
Dim CurrentFolder As String
Dim openedWorkBook As Workbook, HeadingWorkbook As Workbook
Dim OpenedWorkSheet As Worksheet, HeadingWorkSheet As Worksheet
Dim i, counter, x As Integer
Dim LRowHeading, LRowOpenedBook, LColHeading, LColOpenedBook As Long
Dim dict As dictionary
Dim searchValue
'set original workbook with headings to retrieve
Set HeadingWorkbook = ActiveWorkbook
Set HeadingWorkSheet = HeadingWorkbook.Sheets(1)
'find last column on heading worksheet
LColHeading = LastColUsed(HeadingWorkSheet)
'create dictionary to link headers to position in heading worksheet

    Set dict = CreateObject("Scripting.Dictionary")
    For x = 1 To LColHeading
        dict.Add HeadingWorkSheet.Cells(1, x).Value, x
    Next x

FileList() = GetFileListArray()

For counter = 1 To UBound(FileList)
    Set openedWorkBook = Workbooks.Open(CurrentFolder & FileList(counter))
    Set OpenedWorkSheet = openedWorkBook.Sheets(SHEET_TO_SEARCH)
    LColOpenedBook = LastColUsed(openedWorkBook.Sheets(1))
    LRowOpenedBook = LastRowUsed(openedWorkBook.Sheets(1))
    LRowHeading = LastRowUsed(HeadingWorkSheet)

           For i = 1 To LColOpenedBook 'search headers from a1 to last header
                searchValue = OpenedWorkSheet.Cells(1, i).Value 'set search value to current header
                If dict.Exists(searchValue) Then
                      OpenedWorkSheet.Range(OpenedWorkSheet.Cells(1, i), _
                      OpenedWorkSheet.Cells(LRowOpenedBook, i)).Copy _
                      (HeadingWorkSheet.Cells(LRowHeading, dict.Item(searchValue)))
                End If
            Next
        openedWorkBook.Close (False)
Next ' move on to next file

    End Sub

Answer 1

以下是您如何使用字典存储感兴趣的列的名称和列号（基于任意命名的＆＃34; COMPILATION SHEET＆＃34;）。 请记住，您需要启用对＃34; Microsoft Scripting Runtime＆＃34;的引用。

Sub InitiateDictionary()
Dim d As Dictionary
Set d = CreateObject("Scripting.Dictionary")

Dim wb As Workbook, ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets("COMPILATION SHEET")

lastCol = LastColUsed(ws)
For x = 1 To lastCol
    d.Add ws.Cells(1, x), x
Next x
End Sub


Private Function LastColUsed(sh As Worksheet)
On Error Resume Next
LastColUsed = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        LookAt:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
On Error GoTo 0
End Function

您需要做的就是详细说明字典是否包含元素（定义函数DContains(dictionary, string)）。谷歌有关于如何做到这一点的例子。一旦知道标题在字典内，就可以使用该标题名称来了解它所引用的列号。有点像这样：

colNumber = 0
headerToFind = "Header_A"
found = DContains(d, headerToFind)
if found then
    colNumber = d(headerToFind)
end if
if colNumber > 0 then
    'Perform copy to column "colNumber" !
end if

要确定字典中有多少条目，只需使用.Count属性即可。

是的，在这种情况下，Cells(x,1)与Cells(x,1).value相同。

Excel VBA - 将多个文件中的特定列合并到一个工作表中

1 个答案: