Nhờ chỉnh đoạn code vba !

[phiphi2022]

Em có copy trên diễn đàn này đoạn code để copy dữ liệu từ file này qua file khác như sau :

list_path = SelectExcelFiles(, True)
If IsArray(list_path) = False Then Exit Sub

Sheet14.Range("A2:O65000").ClearContents

For Each ex_path In list_path

cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ex_path & _
";Extended Properties=""Excel 12.0;HDR=No;"""

With Sheet14
lR = .Range("A" & .Rows.Count).End(xlUp).Row + 1
Set rs = cn.Execute(sql)
If Not rs.EOF Then .Range("A" & lR).CopyFromRecordset rs
End With

Giờ em muốn đổi biến list_path thay vì mở cửa sổ dẫn và chọn file trong thư mục, giờ em muốn code chọn mặc định tất cả file excel có trong 1 thư mục xác định

cụ thể là chọn tất cả file excel trong thư mục theo đường dẫn này : "G:\15.File TongHop"

Nhờ các anh chị chỉnh lại đoạn code trên dùm em với.

Cảm ơn anh chị nhiều ạ !

 

[Maika8008]

Dùng

Dim fso As Object, oPath, sFile

    Set fso = CreateObject("Scripting.FileSystemObject")
   
    Set oPath = fso.GetFolder("G:\15.File TongHop")
   
    For Each sFile In oPath.Files
        'Code cua ban
        cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ex_path & _
        ";Extended Properties=""Excel 12.0;HDR=No;"""
       
        With Sheet14
        lR = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        Set rs = cn.Execute(Sql)
        If Not rs.EOF Then .Range("A" & lR).CopyFromRecordset rs
        End With
    Next

 

[phiphi2022]

Dùng

Dim fso As Object, oPath, sFile

    Set fso = CreateObject("Scripting.FileSystemObject")
  
    Set oPath = fso.GetFolder("G:\15.File TongHop")
  
    For Each sFile In oPath.Files
        'Code cua ban
        cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ex_path & _
        ";Extended Properties=""Excel 12.0;HDR=No;"""
      
        With Sheet14
        lR = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        Set rs = cn.Execute(Sql)
        If Not rs.EOF Then .Range("A" & lR).CopyFromRecordset rs
        End With
    Next

Cảm ơn anh nhiều ạ !

Bài đã được tự động gộp: 20/10/23

Dùng

Dim fso As Object, oPath, sFile

    Set fso = CreateObject("Scripting.FileSystemObject")
  
    Set oPath = fso.GetFolder("G:\15.File TongHop")
  
    For Each sFile In oPath.Files
        'Code cua ban
        cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ex_path & _
        ";Extended Properties=""Excel 12.0;HDR=No;"""
      
        With Sheet14
        lR = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        Set rs = cn.Execute(Sql)
        If Not rs.EOF Then .Range("A" & lR).CopyFromRecordset rs
        End With
    Next

Em add code vào nó báo lỗi không tìm thấy Path ạ

 

[Maika8008]

Cảm ơn anh nhiều ạ !

Bài đã được tự động gộp: 20/10/23

View attachment 295909
Em add code vào nó báo lỗi không tìm thấy Path ạ

Thay ex_path trong câu lệnh cn.Open... bằng sFile

 

[Maika8008]

À quên. Bạn phải đặt điều kiện ngay sau For...
If Right(sFile.ShortName, 3) = "XLS" Then

Để nó chỉ thi hành với file Excel

 

[VetMini]

Muốn chỉnh theo code chuyên nghiệp (dài) hay chỉ cần sửa code của bạn (ngắn)?

 

[VetMini]

Chắc thớt hết cần rồi.
Đây là cho những bạn nào thắc mắc "cách dài dòng" nghĩa là gì.

Thêm hàm này vào:
Function XLFileNames(fld As String)
' trả về một array gồm tên các files liên hệ đến Excel trong folder fld
Dim fso As Object, a As String
Set fso = CreateObject("Scripting.FileSystemObject")
For Each fl In fso.GetFolder(fld).Files
If fso.getextensionname(fl.Name) Like "xls*" Then a = a & "," & fl.Name
Next fl
If Len(a) <> 0 Then
XLFileNames = Split(Mid(a, 2), ",")
Else
XLFileNames = ""
End If
End Function

Thay dòng này:
list_path = SelectExcelFiles(, True)
Bằng:
list_path = XLFileNames("G:\15.File TongHop")

Giải thích:
Cái hàm cũ, SelectExcelFiles làm công việc mà thớt không thích nữa. Vậy thì viết cái hàm khác, làm đúng ý thích thớt và thay vào. Các phần khác đâu có gì phải lo.