sửa lỗi VBA để giữ nguyên dữ liệu khi copy từ các file excel khác (1 người xem)

[vietlao2003]

Chào các bạn. Mình ko rành về VBA lắm nên nhờ các bạn trợ giúp. Mình có tham khảo trên diễn dàn GPE một chương trìnhviết Macro để ứng dụng cho công việc tổng hợp dữ liệu của mình. Nhưng khi chạy Macro trong sheet 1 của file ketquar(1) thì dữ liệu của của hàng thứ nhất trong sheet 2 ko giữ nguyên như file gốc, hàng sau thì lại giữ giữ nguyên được. Mong các bạn giúp sửa lỗi cho mình nhé

 

[Quang_Hải]

Chào các bạn. Mình ko rành về VBA lắm nên nhờ các bạn trợ giúp. Mình có tham khảo trên diễn dàn GPE một chương trìnhviết Macro để ứng dụng cho công việc tổng hợp dữ liệu của mình. Nhưng khi chạy Macro trong sheet 1 của file ketquar(1) thì dữ liệu của của hàng thứ nhất trong sheet 2 ko giữ nguyên như file gốc, hàng sau thì lại giữ giữ nguyên được. Mong các bạn giúp sửa lỗi cho mình nhé

Dựa vào đâu để sửa code vậy? Bằng niềm tin và hy vọng à? Bao nhiêu % đúng?

 

[vietlao2003]

Mình ko biết làm sao mà ko tải được file lên, hay là thành viên mới nên giới hạn dưới 1MB nhỉ? mình copy code lên vậy

Sub TongHop()
Dim cnn As Object, lsSQL As String, lrs As Object
Dim Fso As Object, fn, Link As String, Fname As String
Set Fso = CreateObject("Scripting.FileSystemObject")
Set cnn = CreateObject("ADODB.Connection")
Set lrs = CreateObject("ADODB.Recordset")


'Mo hop thoai chon thu muc
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
Link = .InitialFileName
Else
MsgBox "Ban da khong chon tong hop", vbInformation, "DHN46 - Thong bao"
Exit Sub
End If
End With
Application.ScreenUpdating = False
'Duyet qua cac thu muc trong Folder
With Fso
For Each fn In .GetFolder(Link).Files
Fname = .BuildPath(Link, fn.Name)
If Fname <> ThisWorkbook.FullName Then
'Tao ket noi CSDL
With cnn
If Val(Application.Version) < 20 Then
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Fname & ";Extended Properties=""Excel 8.0;HDR=No;Imex=1"";"
Else
.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Fname & ";Extended Properties=""Excel 12.0;HDR=No;Imex=1"";"
End If
.Open
End With
'Cau lenh truy van
lsSQL = "SELECT * FROM [T_KE_HK1$A1:AE65536] WHERE F1 in ('TV1')"
lrs.Open lsSQL, cnn, 3, 1
'Xuat ra File
Sheet2.Range("A65536").End(3).Offset(1, 0).CopyFromRecordset lrs
cnn.Close
End If
Next
End With
'Chuyen doi dang Text sang Number
Sheet2.[IV50].Copy
Sheet2.Range("A2", Sheet2.Range("T" & Sheet2.[A65536].End(4).Row)).PasteSpecial xlPasteAll, xlPasteSpecialOperationAdd
Application.ScreenUpdating = True
Set lrs = Nothing
Set cnn = Nothing
End Sub

 

[vietlao2003]

Dựa vào đâu để sửa code vậy? Bằng niềm tin và hy vọng à? Bao nhiêu % đúng?

bạn trả lời nhanh quá, mình đang loay hoay với việc tải file mà

 

[Quang_Hải]

Mình ko biết làm sao mà ko tải được file lên, hay là thành viên mới nên giới hạn dưới 1MB nhỉ? mình copy code lên vậy

Sub TongHop()
Dim cnn As Object, lsSQL As String, lrs As Object
Dim Fso As Object, fn, Link As String, Fname As String
Set Fso = CreateObject("Scripting.FileSystemObject")
Set cnn = CreateObject("ADODB.Connection")
Set lrs = CreateObject("ADODB.Recordset")


'Mo hop thoai chon thu muc
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
Link = .InitialFileName
Else
MsgBox "Ban da khong chon tong hop", vbInformation, "DHN46 - Thong bao"
Exit Sub
End If
End With
Application.ScreenUpdating = False
'Duyet qua cac thu muc trong Folder
With Fso
For Each fn In .GetFolder(Link).Files
Fname = .BuildPath(Link, fn.Name)
If Fname <> ThisWorkbook.FullName Then
'Tao ket noi CSDL
With cnn
If Val(Application.Version) < 20 Then
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Fname & ";Extended Properties=""Excel 8.0;HDR=No;Imex=1"";"
Else
.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Fname & ";Extended Properties=""Excel 12.0;HDR=No;Imex=1"";"
End If
.Open
End With
'Cau lenh truy van
lsSQL = "SELECT * FROM [T_KE_HK1$A1:AE65536] WHERE F1 in ('TV1')"
lrs.Open lsSQL, cnn, 3, 1
'Xuat ra File
Sheet2.Range("A65536").End(3).Offset(1, 0).CopyFromRecordset lrs
cnn.Close
End If
Next
End With
'Chuyen doi dang Text sang Number
Sheet2.[IV50].Copy
Sheet2.Range("A2", Sheet2.Range("T" & Sheet2.[A65536].End(4).Row)).PasteSpecial xlPasteAll, xlPasteSpecialOperationAdd
Application.ScreenUpdating = True
Set lrs = Nothing
Set cnn = Nothing
End Sub

Muốn nhanh thì tải file lên, nhìn code đoán thôi chứ biết dựa vào đâu mà kiểm tra.