[Help] Giúp mình sửa lại code để tổng hợp chạy nhanh hơn

t2bg88 · 16/8/18

Chào mọi người,
mình mới đang tập tành code VBA trong excel, giờ đang phải làm file tổng hợp mà mình code nó vừa dài vừa nặng, chạy đơ cả máy luôn. có bác nào sửa lại giúp mình để file tổng hợp chạy nhanh hơn được không?
Chi tiết mọi người xem trong file đính kèm nhé!
Cảm ơn.

batman1 · 17/8/18

Tôi nghĩ rằng nguyên nhân do tham chiếu tới cả cột.

Hãy nhớ: đừng bao giờ tham chiếu tới cả cột, dù là công thức trên trang tính hay code VBA. Cột có hơn 1 triệu dòng.

Tôi vẫn giữ triết lý của bạn, chỉ rút gọn code thôi.

Hãy thử, và kiểm tra kỹ. Vì tôi không kiểm tra kỹ, liệu thứ tự các sheet tôi xếp có đúng không.

Mã:

Sub Copy_data() 'Lay noi dung tu mot vung xac dinh
Dim shnames, k As Long, lastRow As Long
Dim wb As Workbook
Dim sh As Worksheet
Dim sPath As String, t
'    t = Timer
    Application.ScreenUpdating = False
    sPath = ThisWorkbook.Path & "\" 'Duong dan toi thu muc / hien tai 2 file cung thu muc
    shnames = Array(Array("CP", "DA", "GL", "H1", "H2", "HD", "HP", "HY", "MK", "VT", "VY", "HG", "LC", "MC", "TQ", "YB"), _
                        Array("CP", "DA", "GL", "DTD", "HN2", "HD", "HP", "HY", "MK", "VT", "VY", "HG", "LC", "MC", "TQ", "YB"))
    Set sh = ThisWorkbook.Worksheets("TONG HOP")
    For k = 0 To 15
        Set sh = ThisWorkbook.Worksheets(shnames(1)(k))
        On Error Resume Next
        lastRow = sh.UsedRange.Find("*", sh.UsedRange(1), xlFormulas, xlPart, xlByRows, xlPrevious).Row
        On Error GoTo 0
        If lastRow > 0 Then sh.Range("A1:S" & lastRow).ClearContents
    Next k

    If Dir(sPath & "UNS*.xls*", vbDirectory) = "" Then
        MsgBox "Vui lňng copy Master data vŕo cůng folder voi file nŕy"
        Exit Sub
    End If

    If Dir(sPath & "UNS PTHN.xlsb") <> "" Then
        Set wb = Workbooks.Open(sPath & "UNS PTHN.xlsb")
        For k = 0 To 10
            With wb.Worksheets(shnames(0)(k))
                lastRow = .Cells(Rows.Count, "S").End(xlUp).Row
                .Range("A6:S" & lastRow).AutoFilter Field:=17, Criteria1:="<>0"
                .Range("A1:S" & lastRow).Copy ThisWorkbook.Worksheets(shnames(1)(k)).Range("A1")
            End With
        Next k
        wb.Close False
    Else
        MsgBox "Thieu tap tin UNS PTHN.xlsb"
    End If

    If Dir(sPath & "UNS NPPP.xlsb") <> "" Then
        Set wb = Workbooks.Open(sPath & "UNS NPPP.xlsb")
        For k = 11 To 15
            With wb.Worksheets(shnames(0)(k))
                lastRow = .Cells(Rows.Count, "S").End(xlUp).Row
                .Range("A6:S" & lastRow).AutoFilter Field:=17, Criteria1:="<>0"
                .Range("A1:S" & lastRow).Copy ThisWorkbook.Worksheets(shnames(1)(k)).Range("A1")
            End With
        Next k
        wb.Close False
    Else
        MsgBox "Thieu tap tin UNS NPPP.xlsb"
    End If
    
    Application.ScreenUpdating = False
    MsgBox "Hoŕn Thŕnh", , "Thông Báo"
    
'    Debug.Print Timer - t
End Sub

be_09 · 17/8/18

t2bg88 đã viết:
Chào mọi người,
mình mới đang tập tành code VBA trong excel, giờ đang phải làm file tổng hợp mà mình code nó vừa dài vừa nặng, chạy đơ cả máy luôn. có bác nào sửa lại giúp mình để file tổng hợp chạy nhanh hơn được không?
Chi tiết mọi người xem trong file đính kèm nhé!
Cảm ơn.

Góp ý cho bạn:
1/ Nên dùng phương thức chọn Folder để chọn các File cần lấy dữ liệu vào File tổng hợp, cách này thì sẽ chọn bất kỳ File trong bất kỳ Folder nào.

t2bg88 · 17/8/18

be09 đã viết:
Góp ý cho bạn:
1/ Nên dùng phương thức chọn Folder để chọn các File cần lấy dữ liệu vào File tổng hợp, cách này thì sẽ chọn bất kỳ File trong bất kỳ Folder nào.

bạn giúp mình đoạn code được không? mình không biết phần này. cũng search chưa ra cách làm vậy

Bài đã được tự động gộp: 17/8/18

batman1 đã viết:

Tôi nghĩ rằng nguyên nhân do tham chiếu tới cả cột.

Hãy nhớ: đừng bao giờ tham chiếu tới cả cột, dù là công thức trên trang tính hay code VBA. Cột có hơn 1 triệu dòng.

Tôi vẫn giữ triết lý của bạn, chỉ rút gọn code thôi.

Hãy thử, và kiểm tra kỹ. Vì tôi không kiểm tra kỹ, liệu thứ tự các sheet tôi xếp có đúng không.

Mã:

Sub Copy_data() 'Lay noi dung tu mot vung xac dinh
Dim shnames, k As Long, lastRow As Long
Dim wb As Workbook
Dim sh As Worksheet
Dim sPath As String, t
'    t = Timer
    Application.ScreenUpdating = False
    sPath = ThisWorkbook.Path & "\" 'Duong dan toi thu muc / hien tai 2 file cung thu muc
    shnames = Array(Array("CP", "DA", "GL", "H1", "H2", "HD", "HP", "HY", "MK", "VT", "VY", "HG", "LC", "MC", "TQ", "YB"), _
                        Array("CP", "DA", "GL", "DTD", "HN2", "HD", "HP", "HY", "MK", "VT", "VY", "HG", "LC", "MC", "TQ", "YB"))
    Set sh = ThisWorkbook.Worksheets("TONG HOP")
    For k = 0 To 15
        Set sh = ThisWorkbook.Worksheets(shnames(1)(k))
        On Error Resume Next
        lastRow = sh.UsedRange.Find("*", sh.UsedRange(1), xlFormulas, xlPart, xlByRows, xlPrevious).Row
        On Error GoTo 0
        If lastRow > 0 Then sh.Range("A1:S" & lastRow).ClearContents
    Next k

    If Dir(sPath & "UNS*.xls*", vbDirectory) = "" Then
        MsgBox "Vui lňng copy Master data vŕo cůng folder voi file nŕy"
        Exit Sub
    End If

    If Dir(sPath & "UNS PTHN.xlsb") <> "" Then
        Set wb = Workbooks.Open(sPath & "UNS PTHN.xlsb")
        For k = 0 To 10
            With wb.Worksheets(shnames(0)(k))
                lastRow = .Cells(Rows.Count, "S").End(xlUp).Row
                .Range("A6:S" & lastRow).AutoFilter Field:=17, Criteria1:="<>0"
                .Range("A1:S" & lastRow).Copy ThisWorkbook.Worksheets(shnames(1)(k)).Range("A1")
            End With
        Next k
        wb.Close False
    Else
        MsgBox "Thieu tap tin UNS PTHN.xlsb"
    End If

    If Dir(sPath & "UNS NPPP.xlsb") <> "" Then
        Set wb = Workbooks.Open(sPath & "UNS NPPP.xlsb")
        For k = 11 To 15
            With wb.Worksheets(shnames(0)(k))
                lastRow = .Cells(Rows.Count, "S").End(xlUp).Row
                .Range("A6:S" & lastRow).AutoFilter Field:=17, Criteria1:="<>0"
                .Range("A1:S" & lastRow).Copy ThisWorkbook.Worksheets(shnames(1)(k)).Range("A1")
            End With
        Next k
        wb.Close False
    Else
        MsgBox "Thieu tap tin UNS NPPP.xlsb"
    End If
   
    Application.ScreenUpdating = False
    MsgBox "Hoŕn Thŕnh", , "Thông Báo"
   
'    Debug.Print Timer - t
End Sub

Cảm ơn bạn nhé, code chạy quá nhanh và chính xác

HieuCD · 17/8/18

t2bg88 đã viết:
Chào mọi người,
mình mới đang tập tành code VBA trong excel, giờ đang phải làm file tổng hợp mà mình code nó vừa dài vừa nặng, chạy đơ cả máy luôn. có bác nào sửa lại giúp mình để file tổng hợp chạy nhanh hơn được không?
Chi tiết mọi người xem trong file đính kèm nhé!
Cảm ơn.

Thử code

Mã:

Sub GPE()
  Dim wb As Workbook, cn As Object
  Dim wbArr(), shArr()
  Dim iPath As String, tmp As String
  Dim i As Byte, k As Byte
 
  Set wb = ThisWorkbook
  wbArr = Array("UNS PTHN.xlsb", "UNS NPPP.xlsb")
  shArr = Array(Array("CP", "DA", "DTD", "GL", "HD", "HP", "HY", "MK", "HN2", "VT", "VY"), Array("HG", "LC", "MC", "TQ", "YB"))
  iPath = ThisWorkbook.Path & "\"

  Application.ScreenUpdating = False
  For i = LBound(shArr) To UBound(shArr)
    For k = 0 To UBound(shArr(i))
      Sheets(shArr(i)(k)).UsedRange.ClearContents
    Next k
  Next i
  Set cn = CreateObject("ADODB.Connection")
  For i = LBound(wbArr) To UBound(wbArr)
    If Dir(iPath & wbArr(i)) <> "" Then     
      cn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & iPath & wbArr(i) & ";Extended Properties=""Excel 12.0 macro;HDR=no;imex=1;"";")
      For k = 0 To UBound(shArr(i))
        tmp = shArr(i)(k)
        If tmp = "DTD" Then tmp = "H1"
        If tmp = "HN2" Then tmp = "H2"
        wb.Sheets(shArr(i)(k)).[A1].CopyFromRecordset cn.Execute("select f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11,f12,f13,f14,f15,f16,f17,f18,f19 from [" & tmp & "$] where len(f17)>1 ")
      Next k
      cn.Close
    Else
        MsgBox "Thieu tap tin " & wbArr(i)
    End If
  Next i
  If Not cn Is Nothing Then Set cn = Nothing
  Application.ScreenUpdating = True
End Sub

t2bg88 · 17/8/18

HieuCD đã viết:

Thử code

Mã:

Sub GPE()
  Dim wb As Workbook, cn As Object
  Dim wbArr(), shArr()
  Dim iPath As String, tmp As String
  Dim i As Byte, k As Byte

  Set wb = ThisWorkbook
  wbArr = Array("UNS PTHN.xlsb", "UNS NPPP.xlsb")
  shArr = Array(Array("CP", "DA", "DTD", "GL", "HD", "HP", "HY", "MK", "HN2", "VT", "VY"), Array("HG", "LC", "MC", "TQ", "YB"))
  iPath = ThisWorkbook.Path & "\"

  Application.ScreenUpdating = False
  For i = LBound(shArr) To UBound(shArr)
    For k = 0 To UBound(shArr(i))
      Sheets(shArr(i)(k)).UsedRange.ClearContents
    Next k
  Next i
  Set cn = CreateObject("ADODB.Connection")
  For i = LBound(wbArr) To UBound(wbArr)
    If Dir(iPath & wbArr(i)) <> "" Then  
      cn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & iPath & wbArr(i) & ";Extended Properties=""Excel 12.0 macro;HDR=no;imex=1;"";")
      For k = 0 To UBound(shArr(i))
        tmp = shArr(i)(k)
        If tmp = "DTD" Then tmp = "H1"
        If tmp = "HN2" Then tmp = "H2"
        wb.Sheets(shArr(i)(k)).[A1].CopyFromRecordset cn.Execute("select f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11,f12,f13,f14,f15,f16,f17,f18,f19 from [" & tmp & "$] where len(f17)>1 ")
      Next k
      cn.Close
    Else
        MsgBox "Thieu tap tin " & wbArr(i)
    End If
  Next i
  If Not cn Is Nothing Then Set cn = Nothing
  Application.ScreenUpdating = True
End Sub

Cảm ơn nhé, làm theo cách này cũng rất nhanh, tuy nhiên mình xem chẳng hiểu chút nào, hình như hơi khác lạ so với các code vba excel thường dùng

nhân tiện bạn giúp mình luôn code theo cách bạn Be09 được không?

be09 đã viết:
Góp ý cho bạn:
1/ Nên dùng phương thức chọn Folder để chọn các File cần lấy dữ liệu vào File tổng hợp, cách này thì sẽ chọn bất kỳ File trong bất kỳ Folder nào.

à, mọi người giúp mình thêm phần là sau khi copy xong bỏ wrap text và merge and center các sheet được không?

HieuCD · 17/8/18

t2bg88 đã viết:
Cảm ơn nhé, làm theo cách này cũng rất nhanh, tuy nhiên mình xem chẳng hiểu chút nào, hình như hơi khác lạ so với các code vba excel thường dùng
nhân tiện bạn giúp mình luôn code theo cách bạn Be09 được không?
à, mọi người giúp mình thêm phần là sau khi copy xong bỏ wrap text và merge and center các sheet được không?

Code dùng ADO tăng tốc lấy dữ liệu từ nhiều file kích thước lớn
Cách chọn folder hoặc chọn file tiện cho người dùng, nhưng chỉ lệch 1 chút là phát sinh lổi, các lệnh mẩu mình không có lưu trên máy đang dùng, bạn nhờ người khác viết thêm
Muốn xóa toàn bộ thì thay ".ClearContents" bằng ".Clear", code dùng ADO chỉ copy giá trị

gttrongvn · 17/8/18

Bạn Thử code này xem sao

Mã:

Sub T_H()
Dim t As Double
Dim chon_file As FileDialog
Dim rsCon As Object, cat As Object, tb As Object
Dim FileName As String, SheetName As String
Dim szConnect As String
Dim File_duoc_chon As Variant
Dim Ws As Worksheet
Set chon_file = Application.FileDialog(msoFileDialogFilePicker)
With chon_file
t = Timer
      .Title = "Select files to attach"
      .Filters.Add "Select Files", "*.xlsb"
      .InitialFileName = ThisWorkbook.Path
      If .Show <> -1 Then GoTo NoSelection
            Application.ScreenUpdating = False
            For Each File_duoc_chon In .SelectedItems
                  Set rsCon = CreateObject("ADODB.Connection")
                  Set cat = CreateObject("ADOX.Catalog")
                  Set tb = CreateObject("ADOX.table")
                  FileName = CStr(File_duoc_chon)
                  szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FileName & ";Extended Properties=""Excel 12.0;HDR=NO;IMEX=1"""
                  rsCon.Open szConnect
                  cat.ActiveConnection = rsCon
                  For Each tb In cat.Tables
                        If Len(tb.Name) = 3 Then
                              SheetName = Left(tb.Name, 2)
                              Set Ws = worksheets.Add
                              Ws.Name = SheetName
                              Sheets(SheetName).[A1].CopyFromRecordset rsCon.Execute("SELECT F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,F12,F13,14,F15,F16,F17,F18,F19 FROM [" & tb.Name & "A6:S5000] WHERE LEN(F17)>1 AND F1='" & SheetName & "'")
                        End If
                  Next

            Next
            Application.ScreenUpdating = True
MsgBox Timer - t
End With
NoSelection:
End Sub

[Help] Giúp mình sửa lại code để tổng hợp chạy nhanh hơn

t2bg88

Thành viên mới

File đính kèm

batman1

Thành viên gạo cội

be_09

Biên Hòa, Đồng Nai

t2bg88

Thành viên mới

HieuCD

Chuyên gia GPE

t2bg88

Thành viên mới

HieuCD

Chuyên gia GPE

gttrongvn

Thành viên hoạt động

File đính kèm

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian