从每个工作簿在Excel中使用VBA文件夹中复制一定范围
在本文中，我们将创建一个宏，以将文件夹中多个工作簿中的数据复制到新工作簿中。
我们将创建两个宏；一个宏只会将记录从第一列复制到新工作簿，而第二个宏会将所有数据复制到其中。
此示例的原始数据包括员工的出勤记录。
在TestFolder中，我们有多个Excel文件。 Excel文件的文件名以“ ddmmyyyy”格式表示特定日期。
每个Excel文件都包含该特定日期在职员工的日期，员工ID和员工姓名。
我们创建了两个宏； “ CopyingSingleColumnData”和“ CopyingMultipleColumnData”。 “ CopyingSingleColumnData”宏将仅将文件夹中所有文件的第一列中的记录复制到新工作簿中。 “ CopyingMultipleColumnData”宏会将文件夹中所有文件中的所有数据复制到新工作簿中。
单击“复制单列”按钮可以执行“ CopyingSingleColumnData”宏。单击“复制多列”按钮可以执行“ CopyingMultipleColumnData”宏。
在运行宏之前，必须在文本框中指定放置Excel文件的文件夹的路径。
单击“复制单列”按钮时，将在定义的文件夹中生成一个新的工作簿“ ConsolidatedFile”，该工作簿将包含该文件夹中所有文件的第一列的合并数据。仅在第一列中包含记录。获得合并数据后，我们可以通过对日期数进行计数来找出特定日期的雇员人数。特定日期的计数将等于该特定日期的雇员人数
|单击“复制多列”按钮，它将在定义的文件夹中生成新的工作簿“ ConsolidatedAllColumns”。该工作簿将包含来自该文件夹中所有文件的所有记录的合并数据。
创建的新工作簿将包含文件夹中所有文件的所有记录。获得合并数据后，我们将在一个文件中提供所有出勤详细信息。我们可以轻松地找到该特定日期在职员工的数量，并获得该特定日期在职员工的姓名。
代码说明
Sheet1.TextBox1.Value上面的代码用于从工作表“ Sheet1”中获取插入到文本框“ TextBox1”中的值。
Dir（FolderPath＆“ * .xlsx”）
上面的代码用于获取文件名称，文件扩展名为“ .xlsx”。我们为多个字符文件名使用通配符*。
而FileName <>“”
Count1 = Count1 +1 ReDim保留FileArray（1到Count1）
FileArray（Count1）= FileName FileName = Dir（）
Wend Above代码用于获取文件夹中所有文件的文件名。
对于i = 1到UBound（FileArray）
Next上面的代码用于遍历文件夹中的所有文件。
Range（“ A1”，Cells（LastRow，1））。Copy DestWB.ActiveSheet.Cells（LastDesRow，1）
上面的代码用于将记录从第一列复制到目标工作簿。
Range（“ A1”，ActiveCell.SpecialCells（xlCellTypeLastCell））。Copy DestWB.ActiveSheet.Cells（LastDesRow，1）
上面的代码用于将所有记录从活动工作簿复制到目标工作簿。
请遵循以下代码
如果您喜欢此博客，请在Facebook和Facebook上与您的朋友分享。
Option Explicit
Sub CopyingSingleColumnData()
'Declaring variables
Dim FileName, FolderPath, FileArray(), FileName1 As String
Dim LastRow, LastDesRow, Count1, i As Integer
Dim SourceWB, DestWB As Workbook
Application.ScreenUpdating = False
FolderPath = Sheet1.TextBox1.Value
'Inserting backslash in the folder path if backslash(\) is missing
If Right(FolderPath, 1) <> "\" Then
FolderPath = FolderPath & "\"
End If
'Searching for Excel files
FileName = Dir(FolderPath & "*.xlsx")
Count1 = 0
'Looping through all the Excel files in the folder
While FileName <> ""
Count1 = Count1 + 1
ReDim Preserve FileArray(1 To Count1)
FileArray(Count1) = FileName
FileName = Dir()
Wend
'Creating a new workbook
Set DestWB = Workbooks.Add
For i = 1 To UBound(FileArray)
'Finding the last row in the workbook
LastDesRow = DestWB.ActiveSheet.Range("A1").SpecialCells(xlCellTypeLastCell).Row
'Opening the Excel workbook
Set SourceWB = Workbooks.Open(FolderPath & FileArray(i))
LastRow = ActiveCell.SpecialCells(xlCellTypeLastCell).Row
'Pasting the copied data to last row in the destination workbook
If LastDesRow = 1 Then
'Copying the first column to last row in the destination workbook
Range("A1", Cells(LastRow, 1)).Copy DestWB.ActiveSheet.Cells(LastDesRow, 1)
Else
Range("A1", Cells(LastRow, 1)).Copy DestWB.ActiveSheet.Cells(LastDesRow + 1, 1)
End If
SourceWB.Close False
Next
'Saving and closing a new Excel workbook
DestWB.SaveAs FileName:=FolderPath & "ConsolidatedFile.xlsx"
DestWB.Close
Set DestWB = Nothing
Set SourceWB = Nothing
End Sub
Sub CopyingMultipleColumnData()
'Declaring variables
Dim FileName, FolderPath, FileArray(), FileName1 As String
Dim LastRow, LastDesRow, Count1, i As Integer
Dim SourceWB, DestWB As Workbook
Application.ScreenUpdating = False
FolderPath = Sheet1.TextBox1.Value
'Inserting backslash in the folder path if backslash(\) is missing
If Right(FolderPath, 1) <> "\" Then
FolderPath = FolderPath & "\"
End If
'Searching for Excel files
FileName = Dir(FolderPath & "*.xlsx")
Count1 = 0
'Looping through all the Excel files in the folder
While FileName <> ""
Count1 = Count1 + 1
ReDim Preserve FileArray(1 To Count1)
FileArray(Count1) = FileName
FileName = Dir()
Wend
'Creating a new workbook
Set DestWB = Workbooks.Add
For i = 1 To UBound(FileArray)
'Finding the last row in the workbook
LastDesRow = DestWB.ActiveSheet.Range("A1").SpecialCells(xlCellTypeLastCell).Row
'Opening the Excel workbook
Set SourceWB = Workbooks.Open(FolderPath & FileArray(i))
'Pasting the copied data to last row in the destination workbook
If LastDesRow = 1 Then
'Copying all data in the worksheet to last row in the destination workbook
Range("A1", ActiveCell.SpecialCells(xlCellTypeLastCell)).Copy DestWB.ActiveSheet.Cells(LastDesRow, 1)
Else
Range("A1", ActiveCell.SpecialCells(xlCellTypeLastCell)).Copy DestWB.ActiveSheet.Cells(LastDesRow + 1, 1)
End If
SourceWB.Close False
Next
'Saving and closing a new Excel workbook
DestWB.SaveAs FileName:=FolderPath & "ConsolidatedAllColumns.xlsx"
DestWB.Close
Set DestWB = Nothing
Set SourceWB = Nothing
End Sub
我们很希望收到您的来信，请让我们知道我们如何才能改善我们的工作并使您的工作更好。写信给我们[email protected]