Lấy dữ liệu từ file đang đóng...

Liên hệ QC
S

shnhatha221108

Thành viên chính thức
Tham gia
2/10/18
Bài viết
57
Được thích
11
Em chào các thầy cùng toàn thể anh chị em trên diễn đàm(GPE).Em có một chủ đề muốn nhờ cậy các thầy và anh chị em tham khảo giúp đỡ.
Em có một file_TH muốn lấy toàn bộ dữ liều từ các sheet file_DL đang đóng để tổng hợp..(lấy dữ lieu cùng lúc từ 3 sheet trong file_DL tương ứng sang file_TH)
Em có đọc một số bài về sử dung phương pháp ADO để lấy dữ liệu nhưng khả năng có hạn vẫn chưa hiểu để áp dung được.Vậy mong các thầy và anh chị em giúp đỡ
 

File đính kèm

  • THDL.rar
    1.8 MB · Đọc: 8
shnhatha221108 đã viết:
Em chào các thầy cùng toàn thể anh chị em trên diễn đàm(GPE).Em có một chủ đề muốn nhờ cậy các thầy và anh chị em tham khảo giúp đỡ.
Em có một file_TH muốn lấy toàn bộ dữ liều từ các sheet file_DL đang đóng để tổng hợp..(lấy dữ lieu cùng lúc từ 3 sheet trong file_DL tương ứng sang file_TH)
Em có đọc một số bài về sử dung phương pháp ADO để lấy dữ liệu nhưng khả năng có hạn vẫn chưa hiểu để áp dung được.Vậy mong các thầy và anh chị em giúp đỡ
Nhấp chuột vào đây để mở rộng...
File_TH của bạn có password VBAProject làm sao mở?
Của bạn thì cứ xài thôi.
 
shnhatha221108 đã viết:
Em chào các thầy cùng toàn thể anh chị em trên diễn đàm(GPE).Em có một chủ đề muốn nhờ cậy các thầy và anh chị em tham khảo giúp đỡ.
Em có một file_TH muốn lấy toàn bộ dữ liều từ các sheet file_DL đang đóng để tổng hợp..(lấy dữ lieu cùng lúc từ 3 sheet trong file_DL tương ứng sang file_TH)
Em có đọc một số bài về sử dung phương pháp ADO để lấy dữ liệu nhưng khả năng có hạn vẫn chưa hiểu để áp dung được.Vậy mong các thầy và anh chị em giúp đỡ
Nhấp chuột vào đây để mở rộng...
Bạn thử code bác @HieuCD chỉnh sửa lại cho phù hợp
Mã: 
Sub TongHop()
  Dim Wb As Workbook, WbMain As Workbook, Ws As Worksheet, Dic As Object, Fso As Object, ObjFoder As Object, ObjFile As Object
  Dim Darr(), ShArr(), ShName As String, Tem
  Dim i As Integer, j As Integer, k As Integer, FistC As Byte, LastC As Long, FistR As Byte, LastR As Long
  Application.ScreenUpdating = False
  Set WbMain = ThisWorkbook
  Set Dic = CreateObject("scripting.dictionary")
  ReDim ShArr(i To WbMain.Sheets.Count)
  For k = 1 To WbMain.Sheets.Count
    ShArr(k) = 6
    With WbMain.Sheets(k)
      Dic.Add .Name, k
      LastR = .Range("A" & Rows.Count).End(xlUp).Row
      LastC = .Range("A1").End(xlToRight).Column
      If LastR > 1 And LastC < 16000 Then .Range("A6").Resize(LastR - 1, LastC).ClearContents
    End With
  Next k
  Set Fso = CreateObject("Scripting.FileSystemObject")
  Set ObjFoder = Fso.GetFolder(ThisWorkbook.Path)
  For Each ObjFile In ObjFoder.Files
    If Right(ObjFile, Len(WbMain.Name)) <> WbMain.Name And Fso.GetExtensionName(ObjFile) Like "xls*" Then
      Set Wb = Workbooks.Open(ObjFile)
      For Each Ws In Wb.Sheets
        ShName = Ws.Name
        If Dic.exists(ShName) Then
          If ShName = "Product_Location_3a" Then
            FistR = 3:  FistC = 2
          ElseIf ShName = "Product_Global" Then
            FistR = 3:  FistC = 1
          Else
            FistR = 2:  FistC = 1
          End If
          LastR = Ws.Range("A" & Rows.Count).End(xlUp).Row
          If LastR >= FistR Then
            LastC = Ws.Range("A1").End(xlToRight).Column
            Darr = Ws.Range(Ws.Cells(FistR, FistC), Ws.Cells(LastR, LastC)).Value
            k = Dic.Item(ShName)
            WbMain.Sheets(k).Range("A" & ShArr(k)).Resize(UBound(Darr), UBound(Darr, 2)) = Darr
            ShArr(k) = ShArr(k) + UBound(Darr)
          End If
        End If
      Next Ws
      Wb.Close False
    End If
  Next
  Application.ScreenUpdating = True
End Sub
 

File đính kèm

  • THDL.rar
    1.6 MB · Đọc: 17
LamNA đã viết:
Bạn thử code bác @HieuCD chỉnh sửa lại cho phù hợp
Mã: 
Sub TongHop()
  Dim Wb As Workbook, WbMain As Workbook, Ws As Worksheet, Dic As Object, Fso As Object, ObjFoder As Object, ObjFile As Object
  Dim Darr(), ShArr(), ShName As String, Tem
  Dim i As Integer, j As Integer, k As Integer, FistC As Byte, LastC As Long, FistR As Byte, LastR As Long
  Application.ScreenUpdating = False
  Set WbMain = ThisWorkbook
  Set Dic = CreateObject("scripting.dictionary")
  ReDim ShArr(i To WbMain.Sheets.Count)
  For k = 1 To WbMain.Sheets.Count
    ShArr(k) = 6
    With WbMain.Sheets(k)
      Dic.Add .Name, k
      LastR = .Range("A" & Rows.Count).End(xlUp).Row
      LastC = .Range("A1").End(xlToRight).Column
      If LastR > 1 And LastC < 16000 Then .Range("A6").Resize(LastR - 1, LastC).ClearContents
    End With
  Next k
  Set Fso = CreateObject("Scripting.FileSystemObject")
  Set ObjFoder = Fso.GetFolder(ThisWorkbook.Path)
  For Each ObjFile In ObjFoder.Files
    If Right(ObjFile, Len(WbMain.Name)) <> WbMain.Name And Fso.GetExtensionName(ObjFile) Like "xls*" Then
      Set Wb = Workbooks.Open(ObjFile)
      For Each Ws In Wb.Sheets
        ShName = Ws.Name
        If Dic.exists(ShName) Then
          If ShName = "Product_Location_3a" Then
            FistR = 3:  FistC = 2
          ElseIf ShName = "Product_Global" Then
            FistR = 3:  FistC = 1
          Else
            FistR = 2:  FistC = 1
          End If
          LastR = Ws.Range("A" & Rows.Count).End(xlUp).Row
          If LastR >= FistR Then
            LastC = Ws.Range("A1").End(xlToRight).Column
            Darr = Ws.Range(Ws.Cells(FistR, FistC), Ws.Cells(LastR, LastC)).Value
            k = Dic.Item(ShName)
            WbMain.Sheets(k).Range("A" & ShArr(k)).Resize(UBound(Darr), UBound(Darr, 2)) = Darr
            ShArr(k) = ShArr(k) + UBound(Darr)
          End If
        End If
      Next Ws
      Wb.Close False
    End If
  Next
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn về đoạn code của anh..Anh cho hỏi nếu File_DL không lằm cùng trong một thư mục thì mình phải tạo đường dẫn thế nào để lấy ạ..?
 
shnhatha221108 đã viết:
Cảm ơn về đoạn code của anh..Anh cho hỏi nếu File_DL không lằm cùng trong một thư mục thì mình phải tạo đường dẫn thế nào để lấy ạ..?
Nhấp chuột vào đây để mở rộng...
Vậy bạn thử code nay nhe

Mã: 
Sub TongHop()
    Dim cnn As Object, lsSQL As String, lrs As Object, Fname
    Dim Fso As Object, Link As String, shNameNguon, i As Long
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("ADODB.Connection")
    Set lrs = CreateObject("ADODB.Recordset")
    shNameNguon = Array("MS1", "MS2", "TP")
    Application.ScreenUpdating = False

    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "Microsoft Excel Files", "*.xls; *.xlsx; *.xlsb; *.xlsm", 1
        If .Show = -1 Then
            Link = .InitialFileName
        Else
            MsgBox "Ban da khong chon tong hop", vbInformation, "Thông Báo"
            Exit Sub
        End If
        
        For Each Fname In .SelectedItems
          
            With cnn
                If Val(Application.Version) < 12 Then
                    .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
                                      & "Data Source=" & Fname & ";Extended Properties=""Excel 8.0;HDR=No"";"
                Else
                    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" _
                                      & "Data Source=" & Fname & ";Extended Properties=""Excel 12.0;HDR=No"";"
                End If
                .Open
            
            For i = 0 To UBound(shNameNguon)
          
                lsSQL = "SELECT * FROM [" & shNameNguon(i) & "$A2:AJ65536]"
                lrs.Open lsSQL, cnn, 3, 1
                Sheets(shNameNguon(i)).Range("A6:AK65536").ClearContents
                Sheets(shNameNguon(i)).Range("A65536").End(3).Offset(1, 0).CopyFromRecordset lrs
                lrs.Close
            Next
            End With
        Next
    End With
    Application.ScreenUpdating = True
    cnn.Close
    Set lrs = Nothing
    Set cnn = Nothing
End Sub
 

File đính kèm

  • THDL.rar
    1.6 MB · Đọc: 31
LamNA đã viết:
Vậy bạn thử code nay nhe

Mã: 
Sub TongHop()
    Dim cnn As Object, lsSQL As String, lrs As Object, Fname
    Dim Fso As Object, Link As String, shNameNguon, i As Long
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("ADODB.Connection")
    Set lrs = CreateObject("ADODB.Recordset")
    shNameNguon = Array("MS1", "MS2", "TP")
    Application.ScreenUpdating = False

    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "Microsoft Excel Files", "*.xls; *.xlsx; *.xlsb; *.xlsm", 1
        If .Show = -1 Then
            Link = .InitialFileName
        Else
            MsgBox "Ban da khong chon tong hop", vbInformation, "Thông Báo"
            Exit Sub
        End If
    
        For Each Fname In .SelectedItems
      
            With cnn
                If Val(Application.Version) < 12 Then
                    .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
                                      & "Data Source=" & Fname & ";Extended Properties=""Excel 8.0;HDR=No"";"
                Else
                    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" _
                                      & "Data Source=" & Fname & ";Extended Properties=""Excel 12.0;HDR=No"";"
                End If
                .Open
        
            For i = 0 To UBound(shNameNguon)
      
                lsSQL = "SELECT * FROM [" & shNameNguon(i) & "$A2:AJ65536]"
                lrs.Open lsSQL, cnn, 3, 1
                Sheets(shNameNguon(i)).Range("A6:AK65536").ClearContents
                Sheets(shNameNguon(i)).Range("A65536").End(3).Offset(1, 0).CopyFromRecordset lrs
                lrs.Close
            Next
            End With
        Next
    End With
    Application.ScreenUpdating = True
    cnn.Close
    Set lrs = Nothing
    Set cnn = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ cảm ơn anh..đoạn code này đúng mục đích của em rồi..Xin phiền anh một chút xíu..Giả sử em muốn dùng đoạn code đó để lấy dữ liệu của các File dữ liệu nguồn có tên file và tên các sheet khác(không giống file_DL) thì cần sửa đổi những đoạn code nào ạ?
 
Lần chỉnh sửa cuối:
shnhatha221108 đã viết:
Dạ cảm ơn anh..đoạn code này đúng mục đích của em rồi..Xin phiền anh một chút xíu..Giả sử em muốn dùng đoạn code đó để lấy dữ liệu của các File dữ liệu nguồn có tên file và tên các sheet khác(không giống file_DL) thì cần sửa đổi những đoạn code nào ạ?
Nhấp chuột vào đây để mở rộng...
Bạn thêm ở chỗ này và thêm tên sheet của file tổng hợp
shNameNguon = Array("MS1", "MS2", "TP")
 
shnhatha221108 đã viết:
Nhờ anh kiểm tra lại giúp em..Em chưa hiểu cách thay đổi tên sheet file tổng hợp..
Nhấp chuột vào đây để mở rộng...
3 sheet có tên lần lượt là DLTH1, DLTH2, DLTH3 thì bạn đổi thành

Mã: 
Sửa
shNameNguon = Array("MS1", "MS2", "TP"
Thành
shNameNguon = Array("DLTH1", "DLTH2", "DLTH3")

Mã: 
Sub TongHop()
    Dim cnn As Object, lsSQL As String, lrs As Object, Fname
    Dim Fso As Object, Link As String, shNameNguon, i As Long
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("ADODB.Connection")
    Set lrs = CreateObject("ADODB.Recordset")
    shNameNguon = Array("DLTH1", "DLTH2", "DLTH3")
    Application.ScreenUpdating = False

    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "Microsoft Excel Files", "*.xls; *.xlsx; *.xlsb; *.xlsm", 1
        If .Show = -1 Then
            Link = .InitialFileName
        Else
            MsgBox "Ban da khong chon tong hop", vbInformation, "Thông Báo"
            Exit Sub
        End If
       
        For Each Fname In .SelectedItems
         
            With cnn
                If Val(Application.Version) < 12 Then
                    .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
                                      & "Data Source=" & Fname & ";Extended Properties=""Excel 8.0;HDR=No"";"
                Else
                    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" _
                                      & "Data Source=" & Fname & ";Extended Properties=""Excel 12.0;HDR=No"";"
                End If
                .Open
           
            For i = 0 To UBound(shNameNguon)
         
                lsSQL = "SELECT * FROM [" & shNameNguon(i) & "$A2:AJ65536]"
                lrs.Open lsSQL, cnn, 3, 1
                Sheets(shNameNguon(i)).Range("A6:AK65536").ClearContents
                Sheets(shNameNguon(i)).Range("A65536").End(3).Offset(1, 0).CopyFromRecordset lrs
                lrs.Close
            Next
            End With
        Next
    End With
    Application.ScreenUpdating = True
    cnn.Close
    Set lrs = Nothing
    Set cnn = Nothing
End Sub
Bài đã được tự động gộp:
 

File đính kèm

  • THDL2.rar
    1.7 MB · Đọc: 40
LamNA đã viết:
3 sheet có tên lần lượt là DLTH1, DLTH2, DLTH3 thì bạn đổi thành

Mã: 
Sửa
shNameNguon = Array("MS1", "MS2", "TP"
Thành
shNameNguon = Array("DLTH1", "DLTH2", "DLTH3")

Mã: 
Sub TongHop()
    Dim cnn As Object, lsSQL As String, lrs As Object, Fname
    Dim Fso As Object, Link As String, shNameNguon, i As Long
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("ADODB.Connection")
    Set lrs = CreateObject("ADODB.Recordset")
    shNameNguon = Array("DLTH1", "DLTH2", "DLTH3")
    Application.ScreenUpdating = False

    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "Microsoft Excel Files", "*.xls; *.xlsx; *.xlsb; *.xlsm", 1
        If .Show = -1 Then
            Link = .InitialFileName
        Else
            MsgBox "Ban da khong chon tong hop", vbInformation, "Thông Báo"
            Exit Sub
        End If
     
        For Each Fname In .SelectedItems
       
            With cnn
                If Val(Application.Version) < 12 Then
                    .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
                                      & "Data Source=" & Fname & ";Extended Properties=""Excel 8.0;HDR=No"";"
                Else
                    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" _
                                      & "Data Source=" & Fname & ";Extended Properties=""Excel 12.0;HDR=No"";"
                End If
                .Open
         
            For i = 0 To UBound(shNameNguon)
       
                lsSQL = "SELECT * FROM [" & shNameNguon(i) & "$A2:AJ65536]"
                lrs.Open lsSQL, cnn, 3, 1
                Sheets(shNameNguon(i)).Range("A6:AK65536").ClearContents
                Sheets(shNameNguon(i)).Range("A65536").End(3).Offset(1, 0).CopyFromRecordset lrs
                lrs.Close
            Next
            End With
        Next
    End With
    Application.ScreenUpdating = True
    cnn.Close
    Set lrs = Nothing
    Set cnn = Nothing
End Sub
Bài đã được tự động gộp:
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh..!điều này thì em hiểu rồi ,nhưng em muốn sửa tên các sheet trong file tổng(File_TH) hợp khác với tên các sheet trong file nguồn(File_DL) có được không ạ?Nếu được thì làm thế nào anh chỉ bảo giúp..
 
Lần chỉnh sửa cuối:
Lập 2 mảng, bên nguồn và bên đích

shNguon = Array("File_DL", ...)
shDich = Array("File_TH", ...)
 
shnhatha221108 đã viết:
Cảm ơn anh..!điều này thì em hiểu rồi ,nhưng em muốn sửa tên các sheet trong file tổng(File_TH) hợp khác với tên các sheet trong file nguồn(File_DL) có được không ạ?Nếu được thì làm thế nào anh chỉ bảo giúp..
Nhấp chuột vào đây để mở rộng...
Như hướng dẫn của bác @VetMini bài 13 bạn thử

Mã: 
Sub TongHop()
    Dim cnn As Object, lsSQL As String, lrs As Object, Fname
    Dim Fso As Object, Link As String, shNameNguon, shNameDich, i As Long
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("ADODB.Connection")
    Set lrs = CreateObject("ADODB.Recordset")
    shNameNguon = Array("HS1", "HS2", "TP1")
    shNameDich = Array("DLTH1", "DLTH2", "DLTH3")
    Application.ScreenUpdating = False

    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "Microsoft Excel Files", "*.xls; *.xlsx; *.xlsb; *.xlsm", 1
        If .Show = -1 Then
            Link = .InitialFileName
        Else
            MsgBox "Ban da khong chon tong hop", vbInformation, "Thông Báo"
            Exit Sub
        End If
    
        For Each Fname In .SelectedItems
      
            With cnn
                If Val(Application.Version) < 12 Then
                    .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
                                      & "Data Source=" & Fname & ";Extended Properties=""Excel 8.0;HDR=No"";"
                Else
                    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" _
                                      & "Data Source=" & Fname & ";Extended Properties=""Excel 12.0;HDR=No"";"
                End If
                .Open
        
            For i = 0 To UBound(shNameNguon)
      
                lsSQL = "SELECT * FROM [" & shNameNguon(i) & "$A2:AJ65536]"
                lrs.Open lsSQL, cnn, 3, 1
                Sheets(shNameDich(i)).Range("A6:AK65536").ClearContents
                Sheets(shNameDich(i)).Range("A65536").End(3).Offset(1, 0).CopyFromRecordset lrs
                lrs.Close
            Next
            End With
        Next
    End With
    Application.ScreenUpdating = True
    cnn.Close
    Set lrs = Nothing
    Set cnn = Nothing
End Sub
 
LamNA đã viết:
Như hướng dẫn của bác @VetMini bài 13 bạn thử

Mã: 
Sub TongHop()
    Dim cnn As Object, lsSQL As String, lrs As Object, Fname
    Dim Fso As Object, Link As String, shNameNguon, shNameDich, i As Long
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("ADODB.Connection")
    Set lrs = CreateObject("ADODB.Recordset")
    shNameNguon = Array("HS1", "HS2", "TP1")
    shNameDich = Array("DLTH1", "DLTH2", "DLTH3")
    Application.ScreenUpdating = False

    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "Microsoft Excel Files", "*.xls; *.xlsx; *.xlsb; *.xlsm", 1
        If .Show = -1 Then
            Link = .InitialFileName
        Else
            MsgBox "Ban da khong chon tong hop", vbInformation, "Thông Báo"
            Exit Sub
        End If
  
        For Each Fname In .SelectedItems
    
            With cnn
                If Val(Application.Version) < 12 Then
                    .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
                                      & "Data Source=" & Fname & ";Extended Properties=""Excel 8.0;HDR=No"";"
                Else
                    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" _
                                      & "Data Source=" & Fname & ";Extended Properties=""Excel 12.0;HDR=No"";"
                End If
                .Open
      
            For i = 0 To UBound(shNameNguon)
    
                lsSQL = "SELECT * FROM [" & shNameNguon(i) & "$A2:AJ65536]"
                lrs.Open lsSQL, cnn, 3, 1
                Sheets(shNameDich(i)).Range("A6:AK65536").ClearContents
                Sheets(shNameDich(i)).Range("A65536").End(3).Offset(1, 0).CopyFromRecordset lrs
                lrs.Close
            Next
            End With
        Next
    End With
    Application.ScreenUpdating = True
    cnn.Close
    Set lrs = Nothing
    Set cnn = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Ok..Một lần nữa xin cảm ơn sự nhiệt tình chỉ bảo của anh...Chúc anh và gia đình luôn mạnh khỏe công tác tốt..!
Bài đã được tự động gộp:

VetMini đã viết:
Lập 2 mảng, bên nguồn và bên đích

shNguon = Array("File_DL", ...)
shDich = Array("File_TH", ...)
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh đã quan tâm hộ...Nhận tiện nhờ bạn chỉ bảo giúp câu lệnh trong trường hợp trọn File nguồn không đúng thay vì báo lỗi Debug thì sẽ hiên hộp thoại MsgBox thông bao sai dữ liệu file nguồn ..
 
Lần chỉnh sửa cuối:
LamNA đã viết:
Như hướng dẫn của bác @VetMini bài 13 bạn thử

Mã: 
Sub TongHop()
    Dim cnn As Object, lsSQL As String, lrs As Object, Fname
    Dim Fso As Object, Link As String, shNameNguon, shNameDich, i As Long
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("ADODB.Connection")
    Set lrs = CreateObject("ADODB.Recordset")
    shNameNguon = Array("HS1", "HS2", "TP1")
    shNameDich = Array("DLTH1", "DLTH2", "DLTH3")
    Application.ScreenUpdating = False

    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "Microsoft Excel Files", "*.xls; *.xlsx; *.xlsb; *.xlsm", 1
        If .Show = -1 Then
            Link = .InitialFileName
        Else
            MsgBox "Ban da khong chon tong hop", vbInformation, "Thông Báo"
            Exit Sub
        End If
   
        For Each Fname In .SelectedItems
     
            With cnn
                If Val(Application.Version) < 12 Then
                    .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
                                      & "Data Source=" & Fname & ";Extended Properties=""Excel 8.0;HDR=No"";"
                Else
                    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" _
                                      & "Data Source=" & Fname & ";Extended Properties=""Excel 12.0;HDR=No"";"
                End If
                .Open
       
            For i = 0 To UBound(shNameNguon)
     
                lsSQL = "SELECT * FROM [" & shNameNguon(i) & "$A2:AJ65536]"
                lrs.Open lsSQL, cnn, 3, 1
                Sheets(shNameDich(i)).Range("A6:AK65536").ClearContents
                Sheets(shNameDich(i)).Range("A65536").End(3).Offset(1, 0).CopyFromRecordset lrs
                lrs.Close
            Next
            End With
        Next
    End With
    Application.ScreenUpdating = True
    cnn.Close
    Set lrs = Nothing
    Set cnn = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Gửi anh LamNA lâu rồi em muốn tìm hiểu lại đoạn code trên.Em muốn lấy dữa liệu nhiều file gộp lại thì sửa thế nào ?.Theo em hiểu .AllowMultiSelect = True,cho phép chọn nhiều file nhưng khi em thực hiện chạy code thì báo lỗi không lấy được dữ liệu.Nếu chỉ lấy 1 file thì ok.Nhờ anh chỉnh sừa giúp em .Xin cảm ơn anh
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

T
[Giúp đỡ] Tìm số lượng nhân viên đã tham gia làm lô hàng
Trả lời
3
Đọc
64
hoangtuaotrang_hp_vn
H
hoang.buivan93
Gặp rắc rối về phần công thức hàm tìm kiếm dữ liệu. Nhờ mọi người chỉ giáo giúp ạ.
Trả lời
1
Đọc
36
Hoàng Trọng Nghĩa
Hoàng Trọng Nghĩa
quangminhici
Tặng Addin Word xuất Mail Merge có chức năng cắt ra nhiều file và gửi mail.
    • Thích
Trả lời
8
Đọc
949
thientac
T
A
[Cần Giúp] Excel nhiều người dùng cùng lúc
Trả lời
5
Đọc
121
hvnhpro
H
PhiTQ-ME
  • Question
Nhờ trợ giúp sửa VBA tính diễn giải khối lượng
Trả lời
9
Đọc
131
PhiTQ-ME
PhiTQ-ME
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom