Lấy dữ liệu từ file excel đang đóng, sang file excel đang mở bằng ADODB (ADO)!

[Thư Sinh Áo Trắng]

- Em xin nhờ các anh chị giúp đỡ lấy dữ liệu file excel đang đóng sang file excel đang mở bằng VBA xử dụng ADODB (ADO)
- Em có ngồi kiếm code đễ sửa chữa nhưng đa số code mở lên 1 bảng chọn file, hoặc copy địa chỉ cố định. Hai vấn đề này khiến em không thể sửa code trên mạng để dùng được
- Vì:
+ Dữ liệu em là cập nhật mới, tức là chỉ số dòng luôn tăng lên sau mỗi lần cần lấy dữ liệu => copy địa chỉ cố định là em chết rồi
+ Mỗi lần dùng code, code bắt chọn file, nếu có 600 file thì tức là 600 lần chọn => vậy em cũng chết rồi
- Xin giúp đỡ code VBA xử dụng ADO để lấy dữ liệu file đang đóng sang file đang mở, không bắt chọn file, copy(ghi) được vùng có chỉ số động( luôn tăng)

Em chân thành cảm ơn! Và mong được sự giúp đỡ!
(file đính kèm dang_dong, dang_mo)

 

[Thư Sinh Áo Trắng]

20 triệu cell thì nó bao nhiêu dòng và bao nhiêu cột vậy bạn?

Dạ! Khoảng 15 cái bảng 500.000 x 3 cột ( năm trăm nghìn dòng), với 15 cái bảng cỡ 100.000( môt trăng nghìn dòng) x 3 cột. Em cũng chưa kéo được đến cuối bảng, để xem sao? Do nó lệch dòng các bảng với nhau để kéo xem từng bảng cũng Not ResPending luôn ấy ạ! Còn chạy code thì đau tim lắm! hic hic
Giờ tính lại hóa ra tầm gần 30 triệu Cell/ 1 Sheet ạ!
Và khoảng 600 đến 1000 file như vậy!
Do file quá nặng phải chia tách ra để chạy code VBA, ví nó hay bị Not Respending khổ lắm anh ạ! Do chưa thể cập nhật công nghệ mới nên chơi kiểu phóng to thu nhỏ dữ liệu rồi tính toán ạ!
Thành ra nó nảy sinh mấy chủ đề của em mấy nay ạ!
Chỉnh em code bài 2 với! Em muốn nó là đường dẫn cố định không phải chọn file!
Cảm ơn anh

 

[Thư Sinh Áo Trắng]

Bạn thử code này coi

Ơi anh @buiquangthuan @snow25 @Maika8008 @HieuCD @phuocam
- Ở bài 2: anh @buiquangthuan cho code chạy ứng với trường hợp lấy dữ liệu một vùng của một sheet trong file đóng
- Và ở bài 21 này. Em có nhu cầu lấy dữ liệu một vùng của nhiều Sheet trong file đang đóng. Mô tả như sau:

- Code em chế từ code anh @buiquangthuan như sau:

Sub Get_data_from_multiple_sheets()
Dim cn As Object, rs As Object, sRAddress
Dim eRow&, includeList$, excludeList$, Sql$, shName, CopyAddress, PateAddress, lRAddress, ClearAddress
shName = Array("sh1", "sh2", "sh3")
CopyAddress = Array("$A2:A", "$A2:A", "$A2:A")
PateAddress = Array("A2", "B2", "C2")
lRAddress = Array("A", "B", "C")
ClearAddress = Array("A2:A", "B2:B", "C2:C")
For chon = 0 To 2
    With Sheets("dich")
        eRow = .Range(lRAddress(chon) & Rows.Count).End(xlUp).Row
        If eRow > 2 Then .Range(ClearAddress(chon) & eRow).Clear
    End With
Next chon
    With Application.FileDialog(msoFileDialogFilePicker)
    .Filters.Add "All Excel", "*.xls*"
    .AllowMultiSelect = False
    .Show
    If .SelectedItems.Count < 1 Then MsgBox ("Ban khong chon file nao"): Exit Sub
    If .SelectedItems.Count Then
    On Error Resume Next
    Set cn = CreateObject("adodb.connection")
        cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & .SelectedItems(1) & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
        For chon = 0 To 2
            Sql = "SELECT * FROM [" & shName(chon) & "CopyAddress(chon)] WHERE f1 is not Null" '<---chưa hiểu f1,f2...f9 là gì,chỉ giúp em với nhé!
            Set rs = cn.Execute(Sql)
                If Not rs.EOF Then
                    Sheets("dich").Range(PateAddress(chon)).CopyFromRecordset rs
                End If
        Next chon
        rs.Close:      cn.Close
        Set rs = Nothing: Set cn = Nothing
    On Error GoTo 0
    End If
    End With
End Sub

- Code bài 2 chạy tốt. Mỗi một Sheet của file đóng ta chạy một Sub.
- Các bác giúp em chỉnh code cho phép ghi dữ liệu nhiều sheet của file đóng -> sang file đang mở với ạ! Em chân thành cảm ơn!
(có file đính kèm)

 

[Thư Sinh Áo Trắng]

Đây là code nhờ bác @Maika8008 sửa lại code bài 2 của bác @buiquangthuan ,được code mới trong trường hợp không muốn pick file mà dùng đường dẫn cố định.

Sub lay_data_file_dong_sang_file_mo_Maika8008()
Dim cn As Object, rs As Object, strPath As String
Dim eRow&, includeList$, excludeList$, Sql$
With Sheet1
eRow = .Range("A" & Rows.Count).End(xlUp).Row
If eRow > 2 Then .Range("A2:C" & eRow).Clear
End With
strPath = ThisWorkbook.Path & "\" & "dang_dong.xlsm" 'Duong dan co dinh
On Error Resume Next
Set cn = CreateObject("adodb.connection")
cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & strPath & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
Sql = "SELECT * FROM [$A2:C] WHERE f1 is not Null"
Set rs = cn.Execute(Sql)
If Not rs.EOF Then Sheet1.Range("A2").CopyFromRecordset rs
rs.Close: cn.Close
Set rs = Nothing: Set cn = Nothing
On Error GoTo 0
End Sub

 

[Maika8008]

Bài #22 chưa có lời giải à bạn?

 

[Thư Sinh Áo Trắng]

Bài #22 chưa có lời giải à bạn?

Dạ chưa ạ! Em chạy xong không thấy lỗi, không có gì được ghi ra.
- Giờ có code fix sự kiện pick file thành đường dẫn cố định rồi. Chiều tối về chế ra 2 trường hợp nữa mong rằng cho đứt đuôi con nòng nọc top ADO này!
- Như ở trên:
+ Bài 2 của anh @buiquangthuan code lấy dữ liệu file đòng sang file đang mở, mỗi lần chạy phải pick chọn file
+ Bài 23 của bác @Maika8008 code lấy dữ liệu file đang đóng sang file mở, không phải pick chọn file (đường dẫn cố định)
+ Bài 22 lấy dữ liệu từ nhiều sheet của file đang đóng sang file đang mở, không phải pick chọn file nhưng chưa chạy được. Nhờ bác @Maika8008 giúp em bài này với em có đính kèm file ở bài 22 đấy bác!
+ Bài dự kiến sẽ đăng hỏi: lấy dữ liệu nhiều file đang đóng, trong mỗi file đang đong lại lấy một vài Sheet khác nhau về file đang mở, mà không cần pick chọn!
Nếu được bác để ý đến chắc chắn là xong. Bác giúp em với nhé!

 

[Maika8008]

Dạ chưa ạ! Em chạy xong không thấy lỗi, không có gì được ghi ra.
- Giờ có code fix sự kiện pick file thành đường dẫn cố định rồi. Chiều tối về chế ra 2 trường hợp nữa mong rằng cho đứt đuôi con nòng nọc top ADO này!
- Như ở trên:
+ Bài 2 của anh @buiquangthuan code lấy dữ liệu file đòng sang file đang mở, mỗi lần chạy phải pick chọn file
+ Bài 23 của bác @Maika8008 code lấy dữ liệu file đang đóng sang file mở, không phải pick chọn file (đường dẫn cố định)
+ Bài 22 lấy dữ liệu từ nhiều sheet của file đang đóng sang file đang mở, không phải pick chọn file nhưng chưa chạy được. Nhờ bác @Maika8008 giúp em bài này với em có đính kèm file ở bài 22 đấy bác!
+ Bài dự kiến sẽ đăng hỏi: lấy dữ liệu nhiều file đang đóng, trong mỗi file đang đong lại lấy một vài Sheet khác nhau về file đang mở, mà không cần pick chọn!
Nếu được bác để ý đến chắc chắn là xong. Bác giúp em với nhé!

File của bạn thì sửa strSh = "Sheet" & i thành "Sh" & i
Tôi sửa code bên dưới cũng được nhưng bạn sửa để hiểu thêm 1 chút.

Sub LayNhieuSheet2()
Dim Rec As Object
Dim strPath As String, strSh As String, i As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Sheet1.Range("A2:C5000").ClearContents
    strPath = ThisWorkbook.Path & "\" & "dang_dong.xlsm"    'Duong dan co dinh
    Dim cnn As String
    cnn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strPath & ";Extended Properties=""Excel 12.0 Xml;HDR=No"""
    Set Rec = CreateObject("ADODB.Recordset")
    With Rec
        For i = 1 To 3
            strSh = "Sheet" & i
            .Open ("Select * From [" & strSh & "$A2:A5000] "), cnn
            Sheet1.Cells(2, i).CopyFromRecordset .DataSource
            .Close
        Next
    End With
    Set Rec = Nothing
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "Xong!"
End Sub

 

[Thư Sinh Áo Trắng]

File của bạn thì sửa strSh = "Sheet" & i thành "Sh" & i
Tôi sửa code bên dưới cũng được nhưng bạn sửa để hiểu thêm 1 chút.

Cảm ơn bác nhìn code bài 22 không biết em làm gì mà thấy gớm!
- Bạn giúp cho em bài nữa với ạ!

Có 2 file đang đóng muốn lấy dữ liệu từ 2 file đang dóng về file đang mở. Nhờ bác @Maika8008 và các bác giúp em với!

 

[Maika8008]

Code cho bài #27

Sub LayNhieuSheet1()
Dim Rec As Object
Dim strPath1 As String, strPath2 As String, i As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Sheet1.Range("A2:C5000").ClearContents
    strPath1 = ThisWorkbook.Path & "\" & "dang_dong_2.xlsm"    'Duong dan co dinh
    strPath2 = ThisWorkbook.Path & "\" & "dang_dong_1.xlsm"    'Duong dan co dinh
    Dim cnn As String, cnn2 As String
    cnn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strPath1 & ";Extended Properties=""Excel 12.0 Xml;HDR=No"""
    cnn2 = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strPath2 & ";Extended Properties=""Excel 12.0 Xml;HDR=No"""
    Set Rec = CreateObject("ADODB.Recordset")
    With Rec
        .Open ("Select * From [Date$A2:A5000] "), cnn
        Sheet1.Range("A2").CopyFromRecordset .DataSource
        .Close
        .Open ("Select * From [Time$A2:A5000] WHERE f1 is not Null"), cnn
        Sheet1.Range("B2").CopyFromRecordset .DataSource
        .Close
        .Open ("Select * From [Value$A2:A5000] WHERE f1 is not Null"), cnn
        Sheet1.Range("C2").CopyFromRecordset .DataSource
        .Close
        .Open ("Select * From [Amplitude$A2:B5000] WHERE f1 is not Null"), cnn2
        Sheet1.Range("E2").CopyFromRecordset .DataSource
        .Close
    End With
    Set Rec = Nothing
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "Xong!"
End Sub

 

[Thư Sinh Áo Trắng]

Code cho bài #27

Sub LayNhieuSheet1()
Dim Rec As Object
Dim strPath1 As String, strPath2 As String, i As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Sheet1.Range("A2:C5000").ClearContents
    strPath1 = ThisWorkbook.Path & "\" & "dang_dong_2.xlsm"    'Duong dan co dinh
    strPath2 = ThisWorkbook.Path & "\" & "dang_dong_1.xlsm"    'Duong dan co dinh
    Dim cnn As String, cnn2 As String
    cnn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strPath1 & ";Extended Properties=""Excel 12.0 Xml;HDR=No"""
    cnn2 = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strPath2 & ";Extended Properties=""Excel 12.0 Xml;HDR=No"""
    Set Rec = CreateObject("ADODB.Recordset")
    With Rec
        .Open ("Select * From [Date$A2:A5000] "), cnn
        Sheet1.Range("A2").CopyFromRecordset .DataSource
        .Close
        .Open ("Select * From [Time$A2:A5000] WHERE f1 is not Null"), cnn
        Sheet1.Range("B2").CopyFromRecordset .DataSource
        .Close
        .Open ("Select * From [Value$A2:A5000] WHERE f1 is not Null"), cnn
        Sheet1.Range("C2").CopyFromRecordset .DataSource
        .Close
        .Open ("Select * From [Amplitude$A2:B5000] WHERE f1 is not Null"), cnn2
        Sheet1.Range("E2").CopyFromRecordset .DataSource
        .Close
    End With
    Set Rec = Nothing
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "Xong!"
End Sub

Chân thành cảm ơn bác đã giúp đỡ. Các code đều chạy rất mượt.
Nhìn đống dữ liệu em hàng ngày thấy ngán giờ khỏe quá rồi!

 

[VetMini]

Khoẻ?
Với hàng dữ liệu đó thì trong nghề gọi là data mining. Mà data mining thì người làm tự xoay sở các bề mặt của nó để còn moi ra được tin tức hữu ích. Đằng này nhờ người khác làm thì mỗi lần chuyển mặt hay pivot lại phải nhờ thêm code?

(*1) khi phân tích khảo sát dữ liệu dạng "cube" thì người ta phải thử nhiều mặt, pivot đủ các điểm/trục xoay.

 

[Thư Sinh Áo Trắng]

Khoẻ?
Với hàng dữ liệu đó thì trong nghề gọi là data mining. Mà data mining thì người làm tự xoay sở các bề mặt của nó để còn moi ra được tin tức hữu ích. Đằng này nhờ người khác làm thì mỗi lần chuyển mặt hay pivot lại phải nhờ thêm code?

(*1) khi phân tích khảo sát dữ liệu dạng "cube" thì người ta phải thử nhiều mặt, pivot đủ các điểm/trục xoay.

- Vâng bác!
- Chế ra dữ liệu rồi lại thu nhỏ rồi tính toán rồi quang ra các file(chủ ý do file quá to, hoặc hàm trong VBA giới hạn, chỗ này em sử dụng code nội suy của bác @HieuCD rất nhiều), hiện với code của bác @Maika8008 làm cho việc chia nhỏ file mà vẫn quản lý được không thành vấn đề! Dành thời gian hoàn thiện các bước tính toán rồi em tìm một ngôn ngữ, cách làm phù hợp hơn!
- Đúng ra mà nói dạng bài em đang làm thì phải là một tổ chức có chuyên môn mới ra USD.Thật cảm ơn bác cho những từ khóa mà đọc. Cảm ơn bác @VetMini !
Do tự học và mò mầm sóng Elliott, Hỗ trợ và Kháng cự (là đề cương thôi em cũng chưa nghiên cứu tài liệu nào) mới seach chung chung chưa cụ thể, bác có từng làm qua thì cho em xin hàm có đồ thị hình ziczac.Cho em xin từ khóa cũng may lắm rồi ạ!

 

[HieuCD]

Cảm ơn bác nhìn code bài 22 không biết em làm gì mà thấy gớm!
- Bạn giúp cho em bài nữa với ạ!
View attachment 259502View attachment 259503
Có 2 file đang đóng muốn lấy dữ liệu từ 2 file đang dóng về file đang mở. Nhờ bác @Maika8008 và các bác giúp em với!

Tạo sheet Nguon lưu tên file vả địa chỉ dữ liệu
Chạy code

Sub XYZ()
  Dim rs As Object, cnn As Object, aPath()
  Dim n&, j&, jCol&

  Application.ScreenUpdating = False
  Set cn = CreateObject("adodb.connection")
  With Sheets("Nguon")
    aPath = .Range("A3:K" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With
  jCol = 1
  With Sheets("Sheet1")
    .UsedRange.Offset(1).ClearContents
    For n = 1 To UBound(aPath) Step 2
      cn.Open ("provider=Microsoft.ACE.OLEDB.12.0;data source=" & ThisWorkbook.Path & "\" & _
                aPath(n, 1) & ";mode=Read;extended properties=""Excel 12.0;hdr=no"";")
      For j = 2 To UBound(aPath, 2)
        If aPath(n, j) = Empty Then Exit For
        Set rs = cn.Execute("Select * From [" & aPath(n, j) & "$" & aPath(n + 1, j) & "] where f1 is not null")
        If Not rs.EOF Then .Cells(2, jCol).CopyFromRecordset rs
        rs.Close
        jCol = jCol + Range(aPath(n + 1, j)).Columns.Count
      Next j
      cn.Close
      jCol = jCol + 1
    Next n
  End With
    Set rs = Nothing: Set cn = Nothing
    Application.ScreenUpdating = True
    MsgBox "oK!"
End Sub

 

[kientung]

Chân thành cảm ơn bác đã giúp đỡ. Các code đều chạy rất mượt.
Nhìn đống dữ liệu em hàng ngày thấy ngán giờ khỏe quá rồi!

Code cho bài #27

Sub LayNhieuSheet1()
Dim Rec As Object
Dim strPath1 As String, strPath2 As String, i As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Sheet1.Range("A2:C5000").ClearContents
    strPath1 = ThisWorkbook.Path & "\" & "dang_dong_2.xlsm"    'Duong dan co dinh
    strPath2 = ThisWorkbook.Path & "\" & "dang_dong_1.xlsm"    'Duong dan co dinh
    Dim cnn As String, cnn2 As String
    cnn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strPath1 & ";Extended Properties=""Excel 12.0 Xml;HDR=No"""
    cnn2 = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strPath2 & ";Extended Properties=""Excel 12.0 Xml;HDR=No"""
    Set Rec = CreateObject("ADODB.Recordset")
    With Rec
        .Open ("Select * From [Date$A2:A5000] "), cnn
        Sheet1.Range("A2").CopyFromRecordset .DataSource
        .Close
        .Open ("Select * From [Time$A2:A5000] WHERE f1 is not Null"), cnn
        Sheet1.Range("B2").CopyFromRecordset .DataSource
        .Close
        .Open ("Select * From [Value$A2:A5000] WHERE f1 is not Null"), cnn
        Sheet1.Range("C2").CopyFromRecordset .DataSource
        .Close
        .Open ("Select * From [Amplitude$A2:B5000] WHERE f1 is not Null"), cnn2
        Sheet1.Range("E2").CopyFromRecordset .DataSource
        .Close
    End With
    Set Rec = Nothing
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "Xong!"
End Sub

Em chào thầy @Maika8008

Nếu bài toán là chuyển dữ liệu từ File đang mở vào File đang đóng thì Code sẽ như thế nào thầy .

File đóng sẽ là File chính và hàng ngày sẽ chuyển dữ liệu từ N File con vào File chính

Em cảm ơn.

 

[Maika8008]

Em chào thầy @Maika8008

Nếu bài toán là chuyển dữ liệu từ File đang mở vào File đang đóng thì Code sẽ như thế nào thầy .

File đóng sẽ là File chính và hàng ngày sẽ chuyển dữ liệu từ N File con vào File chính

Em cảm ơn.

Code làm mấy việc sau:
1. Mở file đang đóng
2. Chép dữ liệu vào.
3. Đóng và lưu file.

 

[Kiều Mạnh]

tôi gợi ý cho chút vậy
1/ chọn 1 file Excel bất kỳ có nhiêu Sheet lấy lên hết xong gán dữ liệu nối tiếp xuống 1 sheet
2/ ko cần Open Files
3/ chọn nhiều file cũng thế
.....
thong thả làm đi .... tôi chỉ nói còn ko có làm ... nếu tò mò thì mấy Cái DLL tôi úp trên này nó đã có sẳn rồi
còn ta chỉ khai báo chút là dùng thôi ...

thong thả tìm là thấy

 

[VetMini]

Làm hàng ngày thì học Power Query mà làm. Microsoft tốn công sức ra cai này là để đáp ứng nhu cầu chuyển đổi dữ liệu từ nơi này sang nơi khác. ADO là là một tiện ích đọc/ghi dữ liệu ơ lớp trong (*1), rành nó thì mới có hiệu quả, cứ mỗi nhu cầu lại phải nhờ viết code giùm là khong nên.
Thời buổi công nghệ siêu xa lộ mà bám mãi các kiểu làm cũ rích.

(*1) ứng dụng vi tính có thể ví như củ hành. Những phần mềm có thể thuộc về lớp nào của củ hành. ADO nằm khoảng lớp thứ 3 đếm từ ngoài vào. Trong khi Power Query nằm ở lớp ngoài cùng. Các lớp càng sâu càng đòi hỏi người dùng phải biết về công nghệ và nền tảng công nghẹ.

 

[kientung]

Làm hàng ngày thì học Power Query mà làm. Microsoft tốn công sức ra cai này là để đáp ứng nhu cầu chuyển đổi dữ liệu từ nơi này sang nơi khác. ADO là là một tiện ích đọc/ghi dữ liệu ơ lớp trong (*1), rành nó thì mới có hiệu quả, cứ mỗi nhu cầu lại phải nhờ viết code giùm là khong nên.
Thời buổi công nghệ siêu xa lộ mà bám mãi các kiểu làm cũ rích.

(*1) ứng dụng vi tính có thể ví như củ hành. Những phần mềm có thể thuộc về lớp nào của củ hành. ADO nằm khoảng lớp thứ 3 đếm từ ngoài vào. Trong khi Power Query nằm ở lớp ngoài cùng. Các lớp càng sâu càng đòi hỏi người dùng phải biết về công nghệ và nền tảng công nghẹ.

@VetMini @Kiều Mạnh
Dạ vâng, Em cảm ơn 2 thầy

 

[Kiều Mạnh]

Tôi nghĩ bạn nên tự chủ làm lấy sau này sẻ ko vất vả nhờ nữa

1/ nhờ ai đó làm chạy hết 1s còn mình làm chạy 1 phút = ko sao cả
2/ làm trên tools gì ko quan trọng ... quan trọng là làm được cái gì cho cái việc mình đi nhờ

cố giắng làm chủ cho dù dở ẹc ... còn hơn đi nhờ làm
chịu khó tìm bài trên này chút .... Copy chỉnh sửa xem sao xong tính tiếp .... cứ vậy dần điều là làm được

 

[kientung]

Tôi nghĩ bạn nên tự chủ làm lấy sau này sẻ ko vất vả nhờ nữa

1/ nhờ ai đó làm chạy hết 1s còn mình làm chạy 1 phút = ko sao cả
2/ làm trên tools gì ko quan trọng ... quan trọng là làm được cái gì cho cái việc mình đi nhờ

cố giắng làm chủ cho dù dở ẹc ... còn hơn đi nhờ làm
chịu khó tìm bài trên này chút .... Copy chỉnh sửa xem sao xong tính tiếp .... cứ vậy dần điều là làm được

Dạ em gửi Code của em, cũng tham khảo ở trên diễn đàn rồi làm ạ.

Code ở File Thí nghiệm xuất vào Main

Sub ABC()
    
    Dim wb As Workbook
    Dim Sh, Sheet As Worksheet
    Dim Path, FileName As String
    Dim LrowNguon, LrowPhu, n, n1 As Long
    
      Set wb = ThisWorkbook
      Set Sh = wb.Sheets("Sheet1")
    
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        
          Path = "C:\Users\della\Desktop\Gom Data\"
          FileName = Dir(Path & "Main.xlsm")
           
          Do While FileName <> ""
            Set wb = Application.Workbooks.Open(Path & FileName, WriteResPassword:="QCTEV")
              For Each Sheet In wb.Sheets
                If Sheet.Name = "Data" Then
                   wb.Activate
                   LrowPhu = Sh.Range("C" & Rows.Count).End(3).Row
                   
                     For n = 85 To LrowPhu Step 1
                     LrowNguon = wb.Sheets("Data").Range("B" & Rows.Count).End(3).Row + 1
                
                       For n1 = 2 To 23
                         wb.Sheets("Data").Cells(LrowNguon, n1).Value = Sh.Cells(n, n1).Value
                       Next n1
                       
                     Next n
        
                     wb.Sheets("Data").Range("A2:W" & LrowNguon).Borders.LineStyle = 1
                     wb.Sheets("Data").Range("A2:W" & LrowNguon).Font.Name = "Times New Roman"
                     wb.Sheets("Data").Range("A2:W" & LrowNguon).Font.Size = 12
                     wb.Sheets("Data").Range("A2:W" & LrowNguon).VerticalAlignment = xlCenter
                     wb.Sheets("Data").Range("A2:W" & LrowNguon).HorizontalAlignment = xlCenter
                     
                End If
              Next Sheet
            wb.Close savechanges:=True
          FileName = Dir()
          Loop
          On Error Resume Next
         
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        
        MsgBox ("Xong roi!")
End Sub

 

[Kiều Mạnh]

Dạ em gửi Code của em, cũng tham khảo ở trên diễn đàn rồi làm ạ.

Code ở File Thí nghiệm xuất vào Main

Sub ABC()
   
    Dim wb As Workbook
    Dim Sh, Sheet As Worksheet
    Dim Path, FileName As String
    Dim LrowNguon, LrowPhu, n, n1 As Long
   
      Set wb = ThisWorkbook
      Set Sh = wb.Sheets("Sheet1")
   
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
       
          Path = "C:\Users\della\Desktop\Gom Data\"
          FileName = Dir(Path & "Main.xlsm")
          
          Do While FileName <> ""
            Set wb = Application.Workbooks.Open(Path & FileName, WriteResPassword:="QCTEV")
              For Each Sheet In wb.Sheets
                If Sheet.Name = "Data" Then
                   wb.Activate
                   LrowPhu = Sh.Range("C" & Rows.Count).End(3).Row
                  
                     For n = 85 To LrowPhu Step 1
                     LrowNguon = wb.Sheets("Data").Range("B" & Rows.Count).End(3).Row + 1
               
                       For n1 = 2 To 23
                         wb.Sheets("Data").Cells(LrowNguon, n1).Value = Sh.Cells(n, n1).Value
                       Next n1
                      
                     Next n
       
                     wb.Sheets("Data").Range("A2:W" & LrowNguon).Borders.LineStyle = 1
                     wb.Sheets("Data").Range("A2:W" & LrowNguon).Font.Name = "Times New Roman"
                     wb.Sheets("Data").Range("A2:W" & LrowNguon).Font.Size = 12
                     wb.Sheets("Data").Range("A2:W" & LrowNguon).VerticalAlignment = xlCenter
                     wb.Sheets("Data").Range("A2:W" & LrowNguon).HorizontalAlignment = xlCenter
                    
                End If
              Next Sheet
            wb.Close savechanges:=True
          FileName = Dir()
          Loop
          On Error Resume Next
        
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
       
        MsgBox ("Xong roi!")
End Sub

thế là tốt rồi cứ thế phát huy ....