Copy ra giữ liệu trống

[Yeuvoyeucon]

Kính gửi Anh Chị,
Em có đoạn code thực hiện Copy dữ liệu từ các File và một File. Tuy nhiên kết quả nó ra cái đúng cái sau, cái thiếu...Em đã kiểm tra đảm bảo form của các File đống nhất. Có điều, vùng copy ở các File là dữ liệu có các công thức, sợ code Copy không hiểu và không được. Code này sửa thế nào để nó copy và paste value vào File Tong hop ạ.


Sub Group()
Dim Fso As Object, sPath As String, oFile As Object, i As Long
Set Fso = CreateObject("Scripting.FileSystemObject")
sPath = Fso.GetParentFolderName(ThisWorkbook.FullName)
Sheets("Tonghop").Range("B3:G1000").ClearContents
With CreateObject("ADODB.Connection")
For Each oFile In Fso.GetFolder(sPath).Files
If oFile.Name <> ThisWorkbook.Name And Left(oFile.Name, 1) <> "~" And Fso.GetExtensionName(oFile) Like "xls*" Then
.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=""Excel 12.0;HDR=No"";Data Source=" & Fso.GetAbsolutePathName(oFile)
Sheet1.Range("B" & 3 + i).CopyFromRecordset .Execute("Select * from [KETQUA$B2:H14]")
i = i + 13
.Close
End If
Next
End With
End Sub

 

[Yeuvoyeucon]

Kính gửi Anh Chị,
Em có đoạn code thực hiện Copy dữ liệu từ các File và một File. Tuy nhiên kết quả nó ra cái đúng cái sau, cái thiếu...Em đã kiểm tra đảm bảo form của các File đống nhất. Có điều, vùng copy ở các File là dữ liệu có các công thức, sợ code Copy không hiểu và không được. Code này sửa thế nào để nó copy và paste value vào File Tong hop ạ.


Sub Group()
Dim Fso As Object, sPath As String, oFile As Object, i As Long
Set Fso = CreateObject("Scripting.FileSystemObject")
sPath = Fso.GetParentFolderName(ThisWorkbook.FullName)
Sheets("Tonghop").Range("B3:G1000").ClearContents
With CreateObject("ADODB.Connection")
For Each oFile In Fso.GetFolder(sPath).Files
If oFile.Name <> ThisWorkbook.Name And Left(oFile.Name, 1) <> "~" And Fso.GetExtensionName(oFile) Like "xls*" Then
.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=""Excel 12.0;HDR=No"";Data Source=" & Fso.GetAbsolutePathName(oFile)
Sheet1.Range("B" & 3 + i).CopyFromRecordset .Execute("Select * from [KETQUA$B2:H14]")
i = i + 13
.Close
End If
Next
End With
End Sub

Anh chị nào giúp em với ạ !

 

[cadafi]

Mình thấy code bạn chạy tốt mà. Có thể có 1 file data nào đó dữ liệu bị lệch, hoặc tràn ra khỏi vùng B2:H14 không?
Mình có thêm 2 cột ghi lại số thứ tự file và tên file để bạn tìm và đối chiếu xem file nào thiếu, file nào sai nhé.

Sub Group()
Dim Fso As Object: Set Fso = CreateObject("Scripting.FileSystemObject")
Dim oFile As Object
Dim sPath As String: sPath = Fso.GetParentFolderName(ThisWorkbook.FullName)
Dim i As Long: i = 3
Dim j As Long: j = 0

Sheet1.[B3:J1000].ClearContents

With CreateObject("ADODB.Connection")
    For Each oFile In Fso.GetFolder(sPath).Files
        If oFile.Name <> ThisWorkbook.Name And Left(oFile.Name, 1) <> "~" And Fso.GetExtensionName(oFile) Like "xls*" Then
            j = j + 1
            .Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=""Excel 12.0;HDR=No"";Data Source=" & Fso.GetAbsolutePathName(oFile)
            Sheet1.Cells(i, "B").CopyFromRecordset .Execute("SELECT * FROM [KETQUA$B2:H14]")
            Sheet1.Cells(i, "B").Offset(0, 7).Resize(13) = j
            Sheet1.Cells(i, "B").Offset(0, 8).Resize(13) = Fso.GetAbsolutePathName(oFile)
            i = i + 13
            .Close
        End If
    Next
End With
End Sub

 

[Yeuvoyeucon]

Mình thấy code bạn chạy tốt mà. Có thể có 1 file data nào đó dữ liệu bị lệch, hoặc tràn ra khỏi vùng B2:H14 không?
Mình có thêm 2 cột ghi lại số thứ tự file và tên file để bạn tìm và đối chiếu xem file nào thiếu, file nào sai nhé.

Sub Group()
Dim Fso As Object: Set Fso = CreateObject("Scripting.FileSystemObject")
Dim oFile As Object
Dim sPath As String: sPath = Fso.GetParentFolderName(ThisWorkbook.FullName)
Dim i As Long: i = 3
Dim j As Long: j = 0

Sheet1.[B3:J1000].ClearContents

With CreateObject("ADODB.Connection")
    For Each oFile In Fso.GetFolder(sPath).Files
        If oFile.Name <> ThisWorkbook.Name And Left(oFile.Name, 1) <> "~" And Fso.GetExtensionName(oFile) Like "xls*" Then
            j = j + 1
            .Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=""Excel 12.0;HDR=No"";Data Source=" & Fso.GetAbsolutePathName(oFile)
            Sheet1.Cells(i, "B").CopyFromRecordset .Execute("SELECT * FROM [KETQUA$B2:H14]")
            Sheet1.Cells(i, "B").Offset(0, 7).Resize(13) = j
            Sheet1.Cells(i, "B").Offset(0, 8).Resize(13) = Fso.GetAbsolutePathName(oFile)
            i = i + 13
            .Close
        End If
    Next
End With
End Sub

Em cũng soát lại mẫu đã đảm bảo. Code của anh cũng chạy giống code em đưa lên. nhưng vẫn bị sai. Ô B2 đến B14 là hòa ô, thì có gì cần lưu ý ở code không anh.

 

[cadafi]

Em cũng soát lại mẫu đã đảm bảo. Code của anh cũng chạy giống code em đưa lên. nhưng vẫn bị sai. Ô B2 đến B14 là hòa ô, thì có gì cần lưu ý ở code không anh.

Chào bạn, do không có file mẫu của bạn nên mình không biết kết quả bạn đang đề cập là sai cái gì, sai chỗ nào!? Bạn có thể mô tả rõ hơn chút nữa không!?

 

[Yeuvoyeucon]

Chào bạn, do không có file mẫu của bạn nên mình không biết kết quả bạn đang đề cập là sai cái gì, sai chỗ nào!? Bạn có thể mô tả rõ hơn chút nữa không!?

Dạ File nó đây anh ạ

 

[Nhattanktnn]

Dạ File nó đây anh ạ

Ơ, code này mình viết mà nhỉ. Mà cũng chưa nhìn thấy chỗ dư chỗ thiếu trong ý bạn nói luôn

Bài đã được tự động gộp: 12/4/21

Nhưng sửa vậy chắc hợp lý hơn:

Option Explicit
Sub NTKTNN()
Dim Fso As Object, sPath As String, oFile As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
sPath = Fso.GetParentFolderName(ThisWorkbook.FullName)
Sheets("Tonghop").Cells.ClearContents
    With CreateObject("ADODB.Connection")
        For Each oFile In Fso.GetFolder(sPath).Files
            If oFile.Name <> ThisWorkbook.Name And Left(oFile.Name, 1) <> "~" And Fso.GetExtensionName(oFile) Like "xls*" Then
                .Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=""Excel 12.0;HDR=No"";Data Source=" & Fso.GetAbsolutePathName(oFile)
                Sheets("Tonghop").Cells(Rows.Count, "C").End(xlUp).Offset(1, -1).CopyFromRecordset .Execute("Select * from [Hanghoa$C3:F12]")
                .Close
            End If
        Next
    End With
End Sub

 

[Yeuvoyeucon]

Ơ, code này mình viết mà nhỉ. Mà cũng chưa nhìn thấy chỗ dư chỗ thiếu trong ý bạn nói luôn

Bài đã được tự động gộp: 12/4/21

Nhưng sửa vậy chắc hợp lý hơn:

Option Explicit
Sub NTKTNN()
Dim Fso As Object, sPath As String, oFile As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
sPath = Fso.GetParentFolderName(ThisWorkbook.FullName)
Sheets("Tonghop").Cells.ClearContents
    With CreateObject("ADODB.Connection")
        For Each oFile In Fso.GetFolder(sPath).Files
            If oFile.Name <> ThisWorkbook.Name And Left(oFile.Name, 1) <> "~" And Fso.GetExtensionName(oFile) Like "xls*" Then
                .Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=""Excel 12.0;HDR=No"";Data Source=" & Fso.GetAbsolutePathName(oFile)
                Sheets("Tonghop").Cells(Rows.Count, "C").End(xlUp).Offset(1, -1).CopyFromRecordset .Execute("Select * from [Hanghoa$C3:F12]")
                .Close
            End If
        Next
    End With
End Sub

Dạ,Em tìm trên trang bài code này và thấy hợp nhu cầu nên em hỏi ấy ạ