Mình ví dụ file A và file B là file nguồn , file Tong hop là file đích. Mình muốn copy nối đuôi số liệu sheet b1 của file A và sheet b1 của file B (Điều kiện cột Y không trống thì copy cả dòng) copy vào sheet B1 của file Tong hop bắt đầu từ dòng 10. Khi nhấn code chạy lại thì sẽ cho chọn file cần tổng hợp và chạy code. Nếu chạy lại code thì sẽ copy số liệu lại và đè lên số liệu đã chạy code lần trước. Kết quả mong muốn ở trong file Tong hop. Xin cảm ơn nhiều
Copy nối đuôi nhiều file có cấu trúc giống nhau vào 1 file Tổng hợp
- Thread starter Thbv
- Ngày gửi
Phương Thanh103
Thành viên chính thức
- Tham gia
- 30/1/19
- Bài viết
- 65
- Được thích
- 33
Mình không biết viết code nên không hỗ trợ dc bạn nhiều, chỉ có thể đưa bạn cái code này mình tìm dc trên mạng, có thể sau này dùng. Thường thì mình dùng sub này sau đó filter file tổng hợp để xóa những gì cần xóa.
1. Mở tất cả các file cần gộp khi chạy sub này(không mở những file không cần gộp)
2. File kết quả sẽ được tạo mới.
3. Sau khi có kết quả, cần xóa những dòng tiêu đề vì khi copy, Sub sẽ cop toàn bộ những dòng có data trong file.
Sub MergeMultipleSheetsToNew()
On Error GoTo eh
Dim wbDestination As Workbook
Dim wbSource As Workbook
Dim wsDestination As Worksheet
Dim wb As Workbook
Dim sh As Worksheet
Dim strSheetName As String
Dim strDestName As String
Dim iRws As Integer
Dim iCols As Integer
Dim totRws As Integer
Dim strEndRng As String
Dim rngSource As Range
Application.ScreenUpdating = False
Set wbDestination = Workbooks.Add
strDestName = wbDestination.Name
For Each wb In Application.Workbooks
If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
Set wbSource = wb
For Each sh In wbSource.Worksheets
sh.Activate
ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Activate
iRws = ActiveCell.Row
iCols = ActiveCell.Column
strEndRng = sh.Cells(iRws, iCols).Address
Set rngSource = sh.Range("A1:" & strEndRng)
wbDestination.Activate
Set wsDestination = ActiveSheet
wsDestination.Cells.SpecialCells(xlCellTypeLastCell).Select
totRws = ActiveCell.Row
If totRws + rngSource.Rows.Count > wsDestination.Rows.Count Then
MsgBox "There are not enough rows to place the data in the Consolidation worksheet."
GoTo eh
End If
If totRws <> 1 Then totRws = totRws + 1
rngSource.Copy Destination:=wsDestination.Range("A" & totRws)
Next sh
End If
Next wb
For Each wb In Application.Workbooks
If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
wb.Close False
End If
Next wb
Set wbDestination = Nothing
Set wbSource = Nothing
Set wsDestination = Nothing
Set rngSource = Nothing
Set wb = Nothing
Application.ScreenUpdating = False
Exit Sub
eh:
MsgBox Err.Description
End Sub
Mình cũng hỗ trợ bạn dc nếu bạn cho mình file cụ thể vì mình làm thủ công lắm, ko chuyên nghiệp. Thường mình cũng viết sub filter+copy nối đuôi cho nhiều file do công việc hay tổng hợp data từ Oracle nhưng file phải có tên cụ thể hoặc cú pháp tên cụ thể. Kiểu dạng sub nó sẽ tuần tự như này này:bỏ filter trên file tổng( nếu có)->clear data trên file tổng->mở file data 1+copy data(đoạn này mình để số dòng nhiều)->paste vào file tổng->đóng file data 1->di chuyển chuột xuống dòng cuối cùng chưa dữ liệu+xuống 1 ô nữa->mở file+copy file->paste vào file tổng->đóng file data 2....kiểu kiểu vậy.
1. Mở tất cả các file cần gộp khi chạy sub này(không mở những file không cần gộp)
2. File kết quả sẽ được tạo mới.
3. Sau khi có kết quả, cần xóa những dòng tiêu đề vì khi copy, Sub sẽ cop toàn bộ những dòng có data trong file.
Sub MergeMultipleSheetsToNew()
On Error GoTo eh
Dim wbDestination As Workbook
Dim wbSource As Workbook
Dim wsDestination As Worksheet
Dim wb As Workbook
Dim sh As Worksheet
Dim strSheetName As String
Dim strDestName As String
Dim iRws As Integer
Dim iCols As Integer
Dim totRws As Integer
Dim strEndRng As String
Dim rngSource As Range
Application.ScreenUpdating = False
Set wbDestination = Workbooks.Add
strDestName = wbDestination.Name
For Each wb In Application.Workbooks
If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
Set wbSource = wb
For Each sh In wbSource.Worksheets
sh.Activate
ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Activate
iRws = ActiveCell.Row
iCols = ActiveCell.Column
strEndRng = sh.Cells(iRws, iCols).Address
Set rngSource = sh.Range("A1:" & strEndRng)
wbDestination.Activate
Set wsDestination = ActiveSheet
wsDestination.Cells.SpecialCells(xlCellTypeLastCell).Select
totRws = ActiveCell.Row
If totRws + rngSource.Rows.Count > wsDestination.Rows.Count Then
MsgBox "There are not enough rows to place the data in the Consolidation worksheet."
GoTo eh
End If
If totRws <> 1 Then totRws = totRws + 1
rngSource.Copy Destination:=wsDestination.Range("A" & totRws)
Next sh
End If
Next wb
For Each wb In Application.Workbooks
If wb.Name <> strDestName And wb.Name <> "PERSONAL.XLSB" Then
wb.Close False
End If
Next wb
Set wbDestination = Nothing
Set wbSource = Nothing
Set wsDestination = Nothing
Set rngSource = Nothing
Set wb = Nothing
Application.ScreenUpdating = False
Exit Sub
eh:
MsgBox Err.Description
End Sub
Mình cũng hỗ trợ bạn dc nếu bạn cho mình file cụ thể vì mình làm thủ công lắm, ko chuyên nghiệp. Thường mình cũng viết sub filter+copy nối đuôi cho nhiều file do công việc hay tổng hợp data từ Oracle nhưng file phải có tên cụ thể hoặc cú pháp tên cụ thể. Kiểu dạng sub nó sẽ tuần tự như này này:bỏ filter trên file tổng( nếu có)->clear data trên file tổng->mở file data 1+copy data(đoạn này mình để số dòng nhiều)->paste vào file tổng->đóng file data 1->di chuyển chuột xuống dòng cuối cùng chưa dữ liệu+xuống 1 ô nữa->mở file+copy file->paste vào file tổng->đóng file data 2....kiểu kiểu vậy.
Upvote
0
cảm ơn bạn nhiều nhé
Bài đã được tự động gộp:
Cảm ơn bạn rất nhiều
Upvote
0
Đương nhiên là chịu khó rồi. Thời buổi bi giờ mà còn code VBA tổng hợp dữ liệu là tại người ta thích viết code, chứ không phải tại nhu cầu.
MS đã có công cụ theo thời đại từ 7-8 năm nay rồi. Tổng hợp dữ liệu ngày nay dùng Power Query.
Làm việc với nhiều nguồn dữ liệu mà không biết Power Query là cổ hủ, chậm tiến.
Upvote
0
Bài viết mới nhất
- Question
- Question
