Nhờ anh, chị chỉnh sửa code vba

[Tuan_hcth]

Chào các anh, chị trên diễn đàn

Em đang thực hiện code vba để mở file, duyệt qua các sheets trong file rồi copy vùng dữ liệu và gán vào file tổng hợp nhưng kết quả chưa đúng như mong muốn, cụ thể:
- Nó copy sheets("B") trước rồi mới copy sheets"A" (theo code thì duyệt qua Sheets("A") trước rồi mới đến Sheets("B"));
- Kết quả cuối cùng: số dòng copy gán vào file Tổng hợp có cả dữ liệu của Sheets("B") và Sheets("A") không bằng số dòng sheets("A") + Sheets("B"), mà chỉ bằng số dòng của Sheets("A").
Em nhờ anh, chị xem và sửa giúp em với ạ. Em cảm ơn.

Sub import_sanluong()
Dim wb As Variant
Dim sh As Worksheet
Dim sh1 As Worksheet
Dim dataw As Workbook
Dim lr As Integer


Set sh = Sheet1
Application.ScreenUpdating = False
wb = Application.GetOpenFilename("excel file(*xls.*),*.xls")
If wb = False Then Exit Sub
Set dataw = Workbooks.Open(wb)
For Each sh1 In dataw.Worksheets
lr = sh1.Cells(Rows.Count, 2).End(3).Row
If sh1.Name = "A" Then

sh1.Range("O2:O" & lr).Copy
sh.Range("B4", sh.Range("B10000").End(xlUp)).Offset(1, 0).PasteSpecial
sh1.Range("N2:N" & lr).Copy
sh.Range("C4", sh.Range("C10000").End(xlUp)).Offset(1, 0).PasteSpecial
sh1.Range("M2:M" & lr).Copy
sh.Range("D4", sh.Range("D10000").End(xlUp)).Offset(1, 0).PasteSpecial
sh1.Range("B2:B" & lr).Copy
sh.Range("E4", sh.Range("E10000").End(xlUp)).Offset(1, 0).PasteSpecial
sh1.Range("C2:C" & lr).Copy
sh.Range("F4", sh.Range("F10000").End(xlUp)).Offset(1, 0).PasteSpecial
sh1.Range("G2:G" & lr).Copy
sh.Range("G4", sh.Range("G10000").End(xlUp)).Offset(1, 0).PasteSpecial
sh1.Range("Q2:Q" & lr).Copy
sh.Range("I4", sh.Range("I10000").End(xlUp)).Offset(1, 0).PasteSpecial
End If
If sh1.Name = "B" Then

sh1.Range("A2:A" & lr).Copy
sh.Range("B4", sh.Range("B10000").End(xlUp)).Offset(1, 0).PasteSpecial

sh1.Range("B2:B" & lr).Copy
sh.Range("C4", sh.Range("C10000").End(xlUp)).Offset(1, 0).PasteSpecial

sh1.Range("C2:C" & lr).Copy
sh.Range("D4", sh.Range("D10000").End(xlUp)).Offset(1, 0).PasteSpecial

sh1.Range("D2" & lr).Copy
sh.Range("E4", sh.Range("E10000").End(xlUp)).Offset(1, 0).PasteSpecial
sh1.Range("E2:E" & lr).Copy
sh.Range("F4", sh.Range("F10000").End(xlUp)).Offset(1, 0).PasteSpecial

sh1.Range("F2:F" & lr).Copy
sh.Range("G4", sh.Range("G10000").End(xlUp)).Offset(1, 0).PasteSpecial

sh1.Range("G2:G" & lr).Copy
sh.Range("I4", sh.Range("I10000").End(xlUp)).Offset(1, 0).PasteSpecial

End If
Next sh1

Application.ScreenUpdating = True
Workbooks.Open(wb).Close False

End Sub

 

[snow25]

Chào các anh, chị trên diễn đàn

Em đang thực hiện code vba để mở file, duyệt qua các sheets trong file rồi copy vùng dữ liệu và gán vào file tổng hợp nhưng kết quả chưa đúng như mong muốn, cụ thể:
- Nó copy sheets("B") trước rồi mới copy sheets"A" (theo code thì duyệt qua Sheets("A") trước rồi mới đến Sheets("B"));
- Kết quả cuối cùng: số dòng copy gán vào file Tổng hợp có cả dữ liệu của Sheets("B") và Sheets("A") không bằng số dòng sheets("A") + Sheets("B"), mà chỉ bằng số dòng của Sheets("A").
Em nhờ anh, chị xem và sửa giúp em với ạ. Em cảm ơn.

Sub import_sanluong()
Dim wb As Variant
Dim sh As Worksheet
Dim sh1 As Worksheet
Dim dataw As Workbook
Dim lr As Integer


Set sh = Sheet1
Application.ScreenUpdating = False
wb = Application.GetOpenFilename("excel file(*xls.*),*.xls")
If wb = False Then Exit Sub
Set dataw = Workbooks.Open(wb)
For Each sh1 In dataw.Worksheets
lr = sh1.Cells(Rows.Count, 2).End(3).Row
If sh1.Name = "A" Then

sh1.Range("O2:O" & lr).Copy
sh.Range("B4", sh.Range("B10000").End(xlUp)).Offset(1, 0).PasteSpecial
sh1.Range("N2:N" & lr).Copy
sh.Range("C4", sh.Range("C10000").End(xlUp)).Offset(1, 0).PasteSpecial
sh1.Range("M2:M" & lr).Copy
sh.Range("D4", sh.Range("D10000").End(xlUp)).Offset(1, 0).PasteSpecial
sh1.Range("B2:B" & lr).Copy
sh.Range("E4", sh.Range("E10000").End(xlUp)).Offset(1, 0).PasteSpecial
sh1.Range("C2:C" & lr).Copy
sh.Range("F4", sh.Range("F10000").End(xlUp)).Offset(1, 0).PasteSpecial
sh1.Range("G2:G" & lr).Copy
sh.Range("G4", sh.Range("G10000").End(xlUp)).Offset(1, 0).PasteSpecial
sh1.Range("Q2:Q" & lr).Copy
sh.Range("I4", sh.Range("I10000").End(xlUp)).Offset(1, 0).PasteSpecial
End If
If sh1.Name = "B" Then

sh1.Range("A2:A" & lr).Copy
sh.Range("B4", sh.Range("B10000").End(xlUp)).Offset(1, 0).PasteSpecial

sh1.Range("B2:B" & lr).Copy
sh.Range("C4", sh.Range("C10000").End(xlUp)).Offset(1, 0).PasteSpecial

sh1.Range("C2:C" & lr).Copy
sh.Range("D4", sh.Range("D10000").End(xlUp)).Offset(1, 0).PasteSpecial

sh1.Range("D2" & lr).Copy
sh.Range("E4", sh.Range("E10000").End(xlUp)).Offset(1, 0).PasteSpecial
sh1.Range("E2:E" & lr).Copy
sh.Range("F4", sh.Range("F10000").End(xlUp)).Offset(1, 0).PasteSpecial

sh1.Range("F2:F" & lr).Copy
sh.Range("G4", sh.Range("G10000").End(xlUp)).Offset(1, 0).PasteSpecial

sh1.Range("G2:G" & lr).Copy
sh.Range("I4", sh.Range("I10000").End(xlUp)).Offset(1, 0).PasteSpecial

End If
Next sh1

Application.ScreenUpdating = True
Workbooks.Open(wb).Close False

End Sub

Sửa chỗ này xem.

sh.Range("B4", sh.Range("B10000").End(xlUp)).Offset(1, 0).PasteSpecial
Thành
sh.Range("B4"& sh.Range("B10000").End(xlUp)).Offset(1, 0).PasteSpecial

 

[Tuan_hcth]

Sửa chỗ này xem.

sh.Range("B4", sh.Range("B10000").End(xlUp)).Offset(1, 0).PasteSpecial
Thành
sh.Range("B4"& sh.Range("B10000").End(xlUp)).Offset(1, 0).PasteSpecial

Không được anh ạ. Chạy nó báo lỗi ở dòng: sh.Range("B4"& sh.Range("B10000").End(xlUp)).Offset(1, 0).PasteSpecial này luôn

 

[snow25]

Bạn thử

sh.Range("B"& sh.Range("B10000").End(xlUp).row+1).PasteSpecial

 

[Tuan_hcth]

Bạn thử

sh.Range("B"& sh.Range("B10000").End(xlUp).row+1).PasteSpecial

Được rồi anh ạ. Anh có thể giải thích giúp em được không? Và em thấy code chạy hơi chậm, không biết có giải pháp nào xử lý nhanh hơn không ạ? Em cảm ơn

 

[snow25]

Được rồi anh ạ. Anh có thể giải thích giúp em được không? Và em thấy code chạy hơi chậm, không biết có giải pháp nào xử lý nhanh hơn không ạ? Em cảm ơn

Có cách nhanh hơn.Dùng ADO để lấy dữ liệu vào mản rồi từ mảng đó lấy các giá trị cần thiết.Rồi gán vào excel.

 

[Tuan_hcth]

Có cách nhanh hơn.Dùng ADO để lấy dữ liệu vào mản rồi từ mảng đó lấy các giá trị cần thiết.Rồi gán vào excel.

Anh có đoạn code nào về ADO gần giống với nội dung em nêu thì gửi giúp em với ạ.

 

[VetMini]

Nếu một ngày chỉ chạy một lần thì miễn nó ra đúng kết quả là được rồi. Cải tiến chi cho đêm dài lắm mộng.
Khi nào cần chạy ngày dăm ba lần mới xứng đáng công sức viết code chạy nhanh.

 

[Tuan_hcth]

Nếu một ngày chỉ chạy một lần thì miễn nó ra đúng kết quả là được rồi. Cải tiến chi cho đêm dài lắm mộng.
Khi nào cần chạy ngày dăm ba lần mới xứng đáng công sức viết code chạy nhanh.

Em chỉ sợ dữ liệu nhiều dần lên thị lại càng chậm

 

[VetMini]

Vấn đề tôi quan tâm là một ngày chạy mấy lần.
Chuyện "chạy chậm" và "dữ liệu nhiều" tôi nghe nhiều lắm rồi. Bây giờ mà lên GPE nghe nói "dữ liệu ít" mới lấy làm lạ.

 

[Tuan_hcth]

Có cách nhanh hơn.Dùng ADO để lấy dữ liệu vào mản rồi từ mảng đó lấy các giá trị cần thiết.Rồi gán vào excel.

Theo sự chỉ dẫn của bác snow25, hôm qua em có nghiên cứu về ADO và đã thực hiện được đoạn code dùng ADO kết nối đến file excel và copy dữ liệu về file tổng hợp (chỉ mới copy được 1 sheets duy nhất). Việc duyệt qua các sheets trong file để copy dữ liệu của từng sheets lại chưa biết cách thực hiện. Em nhờ anh, chị xem code dưới đây và bổ sung giúp em với ạ. Em cảm ơn.
Code như sau:

Sub Tong_hop()
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim sh As Worksheet
Dim qr As String
Dim lCounter As Long
Dim lCounter1 As Long
Dim I As Long, k As Long, CountFiles As Long, J As Long
Dim dataw As Workbook
Dim files As Variant
files = Application.GetOpenFilename(, , , , True)
If VarType(files) = vbBoolean Then Exit Sub

For k = LBound(files) To UBound(files)
Set cnn = GetConnXLS(files(k))
If cnn Is Nothing Then
MsgBox "Check lai co so du lieu file: " & files(k)
Exit Sub
End If

qr = "SELECT * from [AA$]"

Set rst = New ADODB.Recordset

rst.Open qr, cnn, adOpenDynamic, adLockOptimistic

lCounter = Sheets("master").Cells(Rows.Count, 1).End(3).Row

While rst.EOF = False
Sheets("master").Range("A" & lCounter).Value = rst.Fields(0)
Sheets("master").Range("B" & lCounter).Value = rst.Fields(1)
Sheets("master").Range("C" & lCounter).Value = rst.Fields(5)

lCounter = lCounter + 1

rst.MoveNext
Wend
rst.Close
Set rst = Nothing
cnn.Close
Set cnn = Nothing

Next k
MsgBox "Done"
End Sub
----------------------------------------------------------------------------
Function GetConnXLS(ByVal cFileName As String, _
Optional ByVal InformErrMSG As Boolean = False)
On Error GoTo errHandling:
'Open ADO connection to excel workbook
Dim oConn As Object
Dim Ext As String, ConnStr As String
Set oConn = CreateObject("ADODB.Connection")

ConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & cFileName & ";" & _
"Extended Properties=""Excel 12.0;HDR=Yes;"";"
oConn.Open ConnStr
Set GetConnXLS = oConn
errHandling:
If Err.Number <> 0 Then
Set oConn = Nothing
If InformErrMSG Then
MsgBox "GetConnXLS" & ": " & Err.Number & " " & Err.Description, vbCritical
End If
End If
End Function

 

[Tuan_hcth]

Theo sự chỉ dẫn của bác snow25, hôm qua em có nghiên cứu về ADO và đã thực hiện được đoạn code dùng ADO kết nối đến file excel và copy dữ liệu về file tổng hợp (chỉ mới copy được 1 sheets duy nhất). Việc duyệt qua các sheets trong file để copy dữ liệu của từng sheets lại chưa biết cách thực hiện. Em nhờ anh, chị xem code dưới đây và bổ sung giúp em với ạ. Em cảm ơn.
Code như sau:

Sub Tong_hop()
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim sh As Worksheet
Dim qr As String
Dim lCounter As Long
Dim lCounter1 As Long
Dim I As Long, k As Long, CountFiles As Long, J As Long
Dim dataw As Workbook
Dim files As Variant
files = Application.GetOpenFilename(, , , , True)
If VarType(files) = vbBoolean Then Exit Sub

For k = LBound(files) To UBound(files)
Set cnn = GetConnXLS(files(k))
If cnn Is Nothing Then
MsgBox "Check lai co so du lieu file: " & files(k)
Exit Sub
End If

qr = "SELECT * from [AA$]"

Set rst = New ADODB.Recordset

rst.Open qr, cnn, adOpenDynamic, adLockOptimistic

lCounter = Sheets("master").Cells(Rows.Count, 1).End(3).Row

While rst.EOF = False
Sheets("master").Range("A" & lCounter).Value = rst.Fields(0)
Sheets("master").Range("B" & lCounter).Value = rst.Fields(1)
Sheets("master").Range("C" & lCounter).Value = rst.Fields(5)

lCounter = lCounter + 1

rst.MoveNext
Wend
rst.Close
Set rst = Nothing
cnn.Close
Set cnn = Nothing

Next k
MsgBox "Done"
End Sub
----------------------------------------------------------------------------
Function GetConnXLS(ByVal cFileName As String, _
Optional ByVal InformErrMSG As Boolean = False)
On Error GoTo errHandling:
'Open ADO connection to excel workbook
Dim oConn As Object
Dim Ext As String, ConnStr As String
Set oConn = CreateObject("ADODB.Connection")

ConnStr = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & cFileName & ";" & _
"Extended Properties=""Excel 12.0;HDR=Yes;"";"
oConn.Open ConnStr
Set GetConnXLS = oConn
errHandling:
If Err.Number <> 0 Then
Set oConn = Nothing
If InformErrMSG Then
MsgBox "GetConnXLS" & ": " & Err.Number & " " & Err.Description, vbCritical
End If
End If
End Function

Ai xem giúp em với ạ. Cảm ơn