我正在尝试合并来自多个csv文件的特定列的数据。此线程：Excel VBA - Merge specific columns from multiple files to one sheet适用于整个列范围。但是，我想要复制，例如来自特定列的每个第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
第一种方法（工作时）导致行从下一列移位（所有粘贴的数据从最后一行开始（不是特定列中的最后一行），它在下面的模式中产生的结果更少（其中cl表示列，x表示数据）：
cl1 cl2 cl3 cl3
x
x
x
x
x
x
x
x
x x
x
x
x
x
x
虽然我想收到以下模式：
cl1 cl2 cl3 cl3
x x x x
x x x x
x x x x
另一个问题是我应该如何修改功能：LastRowUsed不是从A1开始，而是例如来自B1等？我尝试用方法2来解决这个问题。
答案 0 :(得分：0)
根据上面的反馈，我改变了循环顺序并使其有效。我还完善了代码（从范围复制到范围并添加显式选项）。 Code现在正在完成工作。
现在我将尝试将其更改为更高效的版本（需要花费大量时间来处理数百个工作簿）。目前，我正在工作簿之间单独复制和粘贴每个单元格。我认为一组单元格（例如每个第100个单元格的多个选择）会更快。 或者构建所需的值数组并将数组粘贴到headingsWorkbook作为范围。
以下是代码现在的样子：
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