Vba 将多个文件列中的特定单元格合并到一个工作表中

我正在尝试合并来自多个csv文件中特定列的数据。此线程：适用于整个列范围。但是，我想从特定列（而不是当前的整个列）复制例如每个第100个单元格

我已尝试按照以下方法1和2修改代码（见****注释）

此VBA将遍历数据日志文件，这些文件在行中有时间戳，并且每个时间戳都有参数。但是，我不需要所有参数，只需要选定的参数（每列）和每100行中的参数

'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


'takes worksheet and returns last row in column
Private Function LastRowUsedbyCol(sh As Worksheet, ByVal Col As String) As Long
    On Error Resume Next
    LastRowUsed = sh.Cells.Find(What:="*", _
                    After:=sh.Range(Cell(Col, 1), Cell(Col, 1)), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row
    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, vbInformation '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")
    'MsgBox FILESINPATH
    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) = MYPATH & 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, j As Integer
Dim LRowHeading, LRowOpenedBook, LColHeading, LColOpenedBook, LRowHeadingC 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(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 in to current header
        If dict.Exists(searchValue) Then

            ' *** code from previous thread
            'OpenedWorkSheet.Range(OpenedWorkSheet.Cells(1, i), _
            'OpenedWorkSheet.Cells(LRowOpenedBook, i)).Copy _
            '(HeadingWorkSheet.Cells(LRowHeading, dict.Item(searchValue)))

            '**** my proposal
            For j = 1 To LRowOpenedBook Step 100
                OpenedWorkSheet.Range(OpenedWorkSheet.Cells(j, i), _
                OpenedWorkSheet.Cells(j, i)).Copy _
                (HeadingWorkSheet.Cells(LRowHeading + 1, dict.Item(searchValue)))
                LRowHeading = LRowHeading + 1

            '**** my 2nd  proposal
            'LRowHeadingC = HeadingWorkSheet.Cells(Rows.Count, i).End(xlUp).Row
            'For j = 1 To LRowOpenedBook Step 100
                ' OpenedWorkSheet.Range(OpenedWorkSheet.Cells(j, i), _
                'OpenedWorkSheet.Cells(j, i)).Copy _
                '(HeadingWorkSheet.Cells(LRowHeadingC + 1, dict.Item(searchValue)))
                'LRowHeadingC = LRowHeadingC + 1

            Next j

        End If
    Next i
    openedWorkBook.Close (False)
Next counter ' move on to next file

End Sub

虽然我希望收到以下模式：

cl1  cl2  cl3  cl3
x    x    x    x
x    x    x    x
x    x    x    x

---

另一个问题是我应该如何修改函数：LastRow过去不是从A1开始，而是从B1开始，等等。？我试着用方法2解决这个问题。

根据上面的反馈，我改变了循环顺序，这使它工作起来。我还完善了代码（从一个范围复制到另一个范围，并添加了optionexplicit）。代码现在起作用了

现在，我将尝试将其更改为更高效的版本（这需要大量的时间和数百本工作簿）。目前，我正在工作簿之间分别复制和粘贴每个单元格。我认为一组单元格（例如，每100个单元格的多次选择）会更快。 或者构建所需值的数组，并将数组作为范围粘贴到HeadingWorkbook中

下面是代码现在的样子：

    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


        'takes worksheet and returns last row in column
    Private Function LastRowUsedbyCol(sh As Worksheet, ByVal Col As String) As Long
        On Error Resume Next
        LastRowUsed = sh.Cells.Find(What:="*", _
                        After:=sh.Range(Cell(Col, 1), Cell(Col, 1)), _
                        LookAt:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
        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, vbInformation '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")
        'MsgBox FILESINPATH
        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) = MYPATH & FILESINPATH
          FILESINPATH = Dir()
        Loop

GetFileListArray = MYFILES()
End Function

Sub RFSSearchThenCombineEach1000thRow()
'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, j 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(FileList(counter))
    Set OpenedWorkSheet = openedWorkBook.Sheets(SHEET_TO_SEARCH)
    LColOpenedBook = LastColUsed(openedWorkBook.Sheets(1))
    LRowOpenedBook = LastRowUsed(openedWorkBook.Sheets(1))
    LRowHeading = LastRowUsed(HeadingWorkSheet)

        For j = 2 To LRowOpenedBook Step 1000
            LRowHeading = LRowHeading + 1 'move one row down in HeadingWorkbook, each 1000 rows of openedworkbook

                For i = 1 To LColOpenedBook 'search headers from a1 to last header
                     searchValue = OpenedWorkSheet.Cells(1, i).Value 'set search value in to current header
                     If dict.Exists(searchValue) Then

                             OpenedWorkSheet.Range(OpenedWorkSheet.Cells(j, i), _
                             OpenedWorkSheet.Cells(j, i)).Copy _
                             HeadingWorkSheet.Range(HeadingWorkSheet.Cells(LRowHeading, dict.Item(searchValue)), _
                             HeadingWorkSheet.Cells(LRowHeading, dict.Item(searchValue)))

                     End If
                 Next i

        Next j
        openedWorkBook.Close (False)
Next ' move on to next file

    End Sub

选项显式
'获取工作表并返回最后一行
专用函数LastRowUsed（sh作为工作表）的长度为
出错时继续下一步
LastRowUsed=sh.Cells.Find（内容：=“*”_
之后：=sh.Range（“A1”）_
看：=xlPart_
LookIn:=xl公式_
搜索顺序：=xlByRows_
搜索方向：=xlPrevious_
MatchCase:=False）。行
错误转到0
端函数
'获取工作表并返回最后一列
私有函数LastColUsed（sh作为工作表）的长度为
出错时继续下一步
LastColUsed=sh.Cells.Find（What:=“*”_
之后：=sh.范围（A1）_
看：=xlPart_
LookIn:=xl公式_
SearchOrder:=xlByColumns_
搜索方向：=xlPrevious_
MatchCase:=False）。列
错误转到0
端函数
'获取工作表并返回列中的最后一行
私有函数LastRowUsedbyCol（sh作为工作表，ByVal Col作为字符串）的长度为
出错时继续下一步
LastRowUsed=sh.Cells.Find（内容：=“*”_
之后：=sh.Range（单元格（列，1），单元格（列，1））_
看：=xlPart_
LookIn:=xl公式_
搜索顺序：=xlByRows_
搜索方向：=xlPrevious_
MatchCase:=False）。行
错误转到0
端函数
函数GetFileListArray（）作为字符串（）
将文件对话框设置为文件对话框
Dim SelectedFolder作为变量
将MYPATH设置为字符串
将MYFILES（）设置为字符串
暗淡文件输入路径
Dim FNUM，i作为整数
'''''
Set fileDialogBox=Application.FileDialog（msoFileDialogFolderPicker）
'使用With…End With块引用FileDialog对象。
使用文件对话框
如果.Show=-1，则“用户选择了一个文件夹”
对于.SelectedItems中的每个选定文件夹
MYPATH=SelectedFolder'将MYPATH指定给所选文件夹名称
“MsgBox”路径为：“&SelectedFolder，vbInformation”已选择显示文件夹
下一个选定文件夹
'用户按了“取消”。
其他的
MsgBox“已按取消或选择的文件夹无效，正在结束宏”
退出功能
如果结束
以
'将文件对话框对象变量设置为Nothing以清除内存
Set fileDialogBox=Nothing
如果正确（MYPATH，1）“\”则
MYPATH=MYPATH&“\”
如果结束
FILESINPATH=Dir（MYPATH&“*.csv”）
'MsgBox FILESINPATH
如果FILESINPATH=“”，则
MsgBox“未找到任何文件”
退出功能
如果结束
'用文件夹中的Excel文件列表填充数组（myFiles）
FNUM=0
在文件输入路径“”时执行此操作
FNUM=FNUM+1
ReDim保留我的文件（1到FNUM）
MYFILES（FNUM）=MYPATH和FILESINPATH
FILESINPATH=Dir（）
环
GetFileListArray=MYFILES（）
端函数
子RFSSearchThenCombineeACH1000抛出（）
'搜索打开文件中的第一个工作表，更改为搜索其他工作表
Const SHEET_TO_SEARCH=1
Dim FileList（）作为字符串
将当前文件夹设置为字符串
将打开的工作簿变暗为工作簿，将标题工作簿变为工作簿
将打开的工作表标注为工作表，将标题工作表标注为工作表
尺寸i、计数器、x、j为整数
变暗LRowHeading、LRowOpenedBook、lColoHeading、lColoPeedBook等长
字典
模糊搜索值
'设置要检索的标题为的原始工作簿
设置标题工作簿=活动工作簿
设置标题工作表=标题工作簿。工作表（1）
'查找标题工作表上的最后一列
LColHeading=LastColUsed（标题工作表）
'创建字典以将标题链接到标题工作表中的位置
Set dict=CreateObject（“Scripting.Dictionary”）
对于x=1至LColHeading
添加标题工作表。单元格（1，x）。值，x
下一个x
FileList（）=GetFileListArray（）
对于计数器=1到UBound（文件列表）
设置openedWorkBook=工作簿。打开（文件列表（计数器））
设置OpenedWorkSheet=openedWorkBook.Sheets（工作表到工作表搜索）
LColopedBook=LastColUsed（打开的工作簿表（1））
LRowOpenedBook=LastRowUsed（openedWorkBook.Sheets（1））
LRowHeading=LastRowUsed（标题工作表）
对于j=2至LRowOpenedBook步骤1000
LRowHeading=LRowHeading+1
    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


        'takes worksheet and returns last row in column
    Private Function LastRowUsedbyCol(sh As Worksheet, ByVal Col As String) As Long
        On Error Resume Next
        LastRowUsed = sh.Cells.Find(What:="*", _
                        After:=sh.Range(Cell(Col, 1), Cell(Col, 1)), _
                        LookAt:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
        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, vbInformation '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")
        'MsgBox FILESINPATH
        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) = MYPATH & FILESINPATH
          FILESINPATH = Dir()
        Loop

GetFileListArray = MYFILES()
End Function

Sub RFSSearchThenCombineEach1000thRow()
'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, j 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(FileList(counter))
    Set OpenedWorkSheet = openedWorkBook.Sheets(SHEET_TO_SEARCH)
    LColOpenedBook = LastColUsed(openedWorkBook.Sheets(1))
    LRowOpenedBook = LastRowUsed(openedWorkBook.Sheets(1))
    LRowHeading = LastRowUsed(HeadingWorkSheet)

        For j = 2 To LRowOpenedBook Step 1000
            LRowHeading = LRowHeading + 1 'move one row down in HeadingWorkbook, each 1000 rows of openedworkbook

                For i = 1 To LColOpenedBook 'search headers from a1 to last header
                     searchValue = OpenedWorkSheet.Cells(1, i).Value 'set search value in to current header
                     If dict.Exists(searchValue) Then

                             OpenedWorkSheet.Range(OpenedWorkSheet.Cells(j, i), _
                             OpenedWorkSheet.Cells(j, i)).Copy _
                             HeadingWorkSheet.Range(HeadingWorkSheet.Cells(LRowHeading, dict.Item(searchValue)), _
                             HeadingWorkSheet.Cells(LRowHeading, dict.Item(searchValue)))

                     End If
                 Next i

        Next j
        openedWorkBook.Close (False)
Next ' move on to next file

    End Sub