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

Liên hệ QC
T

t2bg88

Thành viên mới
Tham gia
18/10/16
Bài viết
30
Được thích
11
Giới tính
Nam
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.
 

File đính kèm

  • Tong hop.rar
    2.8 MB · Đọc: 37
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Tôi nghĩ rằng nguyên nhân do tham chiếu tới cả cột.

Hãy nhớ: đừng bao giờ tham chiếu tới cả cột, dù là công thức trên trang tính hay code VBA. Cột có hơn 1 triệu dòng.

Tôi vẫn giữ triết lý của bạn, chỉ rút gọn code thôi.

Hãy thử, và kiểm tra kỹ. Vì tôi không kiểm tra kỹ, liệu thứ tự các sheet tôi xếp có đú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
 
Upvote 0
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.
Nhấp chuột vào đây để mở rộng...
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.
 
Lần chỉnh sửa cuối:
Upvote 0
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.
Nhấp chuột vào đây để mở rộng...
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:

batman1 đã viết:
Tôi nghĩ rằng nguyên nhân do tham chiếu tới cả cột.

Hãy nhớ: đừng bao giờ tham chiếu tới cả cột, dù là công thức trên trang tính hay code VBA. Cột có hơn 1 triệu dòng.

Tôi vẫn giữ triết lý của bạn, chỉ rút gọn code thôi.

Hãy thử, và kiểm tra kỹ. Vì tôi không kiểm tra kỹ, liệu thứ tự các sheet tôi xếp có đú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
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn nhé, code chạy quá nhanh và chính xác :)
 
Lần chỉnh sửa cuối:
Upvote 0
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.
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
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 :D
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.
Nhấp chuột vào đây để mở rộ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?
 
Upvote 0
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 :D
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?
Nhấp chuột vào đây để mở rộ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ị
 
Upvote 0
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
 

File đính kèm

  • TONG HOP_1.xlsb
    54.7 KB · Đọc: 12
Lần chỉnh sửa cuối:
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

vova2209
Hàm if điều kiện mảng
Trả lời
9
Đọc
158
VetMini
V
nnthoi1994
Tự động gửi tin nhắn skype thông qua VBA
    • Thích
Trả lời
17
Đọc
660
nnthoi1994
nnthoi1994
LuuAnh980
Công thức lọc không trùng đơn hàng.
Trả lời
9
Đọc
126
LuuAnh980
LuuAnh980
H
Tính tổng có điều kiện
Trả lời
3
Đọc
76
Hoàng Tuấn 868
H
D
  • Question
nhờ các bạn trong diễn đàn chỉ giúp cách duyệt qua các phần tử của mảng 4 chiều
Trả lời
7
Đọc
93
VetMini
V
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom