Sao chép một Phạm vi từ mỗi sổ làm việc trong một thư mục bằng VBA trong Microsoft Excel

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