Copy ra giữ liệu trống

MyVTV Add-ins

hoangquandu

Thành viên mới
Tham gia ngày
30 Tháng mười 2009
Bài viết
49
Được thích
4
Điểm
603
Tuổi
27
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
 

hoangquandu

Thành viên mới
Tham gia ngày
30 Tháng mười 2009
Bài viết
49
Được thích
4
Điểm
603
Tuổi
27
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

Working with mind, Living with nature!
Thành viên BQT
Super Moderator
Tham gia ngày
27 Tháng năm 2007
Bài viết
4,277
Được thích
11,306
Điểm
4,418
Tuổi
40
Nơi ở
HCM
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é.

PHP:
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
 

File đính kèm

  • File_Tong.xlsm
    27.7 KB · Đọc: 5

hoangquandu

Thành viên mới
Tham gia ngày
30 Tháng mười 2009
Bài viết
49
Được thích
4
Điểm
603
Tuổi
27
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é.

PHP:
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

Working with mind, Living with nature!
Thành viên BQT
Super Moderator
Tham gia ngày
27 Tháng năm 2007
Bài viết
4,277
Được thích
11,306
Điểm
4,418
Tuổi
40
Nơi ở
HCM
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!?
 

hoangquandu

Thành viên mới
Tham gia ngày
30 Tháng mười 2009
Bài viết
49
Được thích
4
Điểm
603
Tuổi
27

File đính kèm

  • File 1.xlsx
    9.6 KB · Đọc: 4
  • File 2.xlsx
    9.1 KB · Đọc: 5
  • Gop du lieu.xlsm
    20.3 KB · Đọc: 4

Nhattanktnn

Thành viên gắn bó
Tham gia ngày
11 Tháng mười một 2016
Bài viết
1,639
Được thích
1,595
Điểm
668
Ơ, 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:

Nhưng sửa vậy chắc hợp lý hơn:
Mã:
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
 
Lần chỉnh sửa cuối:

hoangquandu

Thành viên mới
Tham gia ngày
30 Tháng mười 2009
Bài viết
49
Được thích
4
Điểm
603
Tuổi
27
Ơ, 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:

Nhưng sửa vậy chắc hợp lý hơn:
Mã:
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 ạ
 
Top Bottom