Tối ưu đoạn code tổng hợp các file lại thành một file tổng.

khoavu87 · 12/4/11

PHP:

Private Sub CommandButton1_Click()
    Dim i As Byte
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
            ThisWorkbook.Sheets(1).[a1:d2].ClearContents
    For i = 1 To ThisWorkbook.Sheets(1).Range("h1").Value
        Workbooks.Open ThisWorkbook.Path & "\" & i & ".xls"
            ActiveWorkbook.Sheets(1).[a1:d2].Copy
ThisWorkbook.Sheets(1).[a1:d2].PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd
        ActiveWorkbook.Close False
    Next i
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Em có các file dữ liệu và file tổng trong một foder , khi chạy đoạn code để tổng tất cả các cells trong các file nào tương ứng cells trong file tổng bằng code trên thì thấy chưa ưng ý lắm vẫn thấy chạy lâu lâu.
+Vậy em hỏi có cách nào tối ưu code trên hoặc code này có thể nhanh hơn không ạ. ?
+Em có kèm theo file.

ndu96081631 · 13/4/11

khoavu87 đã viết:
PHP:

Private Sub CommandButton1_Click() Dim i As Byte Application.ScreenUpdating = False Application.DisplayAlerts = False ThisWorkbook.Sheets(1).[a1:d2].ClearContents For i = 1 To ThisWorkbook.Sheets(1).Range("h1").Value Workbooks.Open ThisWorkbook.Path & "\" & i & ".xls" ActiveWorkbook.Sheets(1).[a1:d2].Copy ThisWorkbook.Sheets(1).[a1:d2].PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd ActiveWorkbook.Close False Next i Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

Em có các file dữ liệu và file tổng trong một foder , khi chạy đoạn code để tổng tất cả các cells trong các file nào tương ứng cells trong file tổng bằng code trên thì thấy chưa ưng ý lắm vẫn thấy chạy lâu lâu.
+Vậy em hỏi có cách nào tối ưu code trên hoặc code này có thể nhanh hơn không ạ. ?
+Em có kèm theo file.

Thử vầy xem:

PHP:

Private Sub CommandButton1_Click()
  Dim i As Long, stPath As String, lwb As Long, Target As Range, Clls As Range
  With ThisWorkbook
    Set Target = .Sheets(1).Range("A1:D2")
    lwb = .Sheets(1).Range("H1").Value
    For Each Clls In Target
      stPath = ""
      For i = 1 To lwb
        stPath = stPath & "+'" & .Path & "\[" & i & ".xls]1'!" & Clls.Address(0, 0)
      Next
      Clls.Value = "=" & stPath
      Clls.Value = Clls.Value
    Next
  End With
End Sub

Ngoài code này ra, bạn hãy nghiên cứu Consolidate đi, nó làm được vụ này đấy

khoavu87 · 14/4/11

ndu96081631 đã viết:

Thử vầy xem:

PHP:

Private Sub CommandButton1_Click()
  Dim i As Long, stPath As String, lwb As Long, Target As Range, Clls As Range
  With ThisWorkbook
    Set Target = .Sheets(1).Range("A1:D2")
    lwb = .Sheets(1).Range("H1").Value
    For Each Clls In Target
      stPath = ""
      For i = 1 To lwb
        stPath = stPath & "+'" & .Path & "\[" & i & ".xls]1'!" & Clls.Address(0, 0)
      Next
      Clls.Value = "=" & stPath
      Clls.Value = Clls.Value
    Next
  End With
End Sub

Ngoài code này ra, bạn hãy nghiên cứu Consolidate đi, nó làm được vụ này đấy

Cảm ơn anh Ndu nhiều ạ, hai hôm nay đi làm bận quá nên hôm nay mới có thời gian lên xem code. Tối về em thử xem thế nào.
+ Anh Ndu ơi anh bảo cái vụ Consolidate này em thấy hay hay. Nhưng không biết tài liệu trên diễn đàn thì tài liệu hay và dễ hiểu nào được nhỉ? Bác cho em cái link nhé. Em cảm ơn Bác.

ndu96081631 · 14/4/11

khoavu87 đã viết:
+ Anh Ndu ơi anh bảo cái vụ Consolidate này em thấy hay hay. Nhưng không biết tài liệu trên diễn đàn thì tài liệu hay và dễ hiểu nào được nhỉ? Bác cho em cái link nhé. Em cảm ơn Bác.

Cũng file của bạn, tôi sẽ làm bằng Consolidate đây. Down về tham khảo nha
Code:

PHP:

Sub ConsolMutiFiles(Folder As String, ShName As String, SrcRng As String, lWb As Long, Target As Range)
  Dim Temp As String, Arr, i As Long
  ReDim Arr(1 To 1000)
  Temp = ShName & "'!" & Range(SrcRng).Address(, , 2)
  If Right(Folder, 1) <> "\" Then Folder = Folder & "\"
  ActiveWorkbook.Names.Add "Arr", "=""'" & Folder & "[""&Files(""" & Folder & "*.*"")&""]" & Temp & """"
  Arr = Evaluate("Arr")
  ReDim Preserve Arr(1 To lWb)
  Target.Consolidate Arr, 9, 0, 0
  ActiveWorkbook.Names("Arr").Delete
End Sub

PHP:

Sub Main()
  Dim Folder As String, ShName As String, SrcRng As String, lWb As Long
  Range("A1:E1000").ClearContents
  Folder = ThisWorkbook.Path & "\Source"
  ShName = "1": SrcRng = "A1:D30"
  lWb = Range("H1").Value
  ConsolMutiFiles Folder, ShName, SrcRng, lWb, Range("A1")
End Sub

khoavu87 · 15/4/11

ndu96081631 đã viết:

Cũng file của bạn, tôi sẽ làm bằng Consolidate đây. Down về tham khảo nha
Code:

PHP:

Sub ConsolMutiFiles(Folder As String, ShName As String, SrcRng As String, lWb As Long, Target As Range)
  Dim Temp As String, Arr, i As Long
  ReDim Arr(1 To 1000)
  Temp = ShName & "'!" & Range(SrcRng).Address(, , 2)
  If Right(Folder, 1) <> "\" Then Folder = Folder & "\"
  ActiveWorkbook.Names.Add "Arr", "=""'" & Folder & "[""&Files(""" & Folder & "*.*"")&""]" & Temp & """"
  Arr = Evaluate("Arr")
  ReDim Preserve Arr(1 To lWb)
  Target.Consolidate Arr, 9, 0, 0
  ActiveWorkbook.Names("Arr").Delete
End Sub

PHP:

Sub Main()
  Dim Folder As String, ShName As String, SrcRng As String, lWb As Long
  Range("A1:E1000").ClearContents
  Folder = ThisWorkbook.Path & "\Source"
  ShName = "1": SrcRng = "A1:D30"
  lWb = Range("H1").Value
  ConsolMutiFiles Folder, ShName, SrcRng, lWb, Range("A1")
End Sub

+ Em đang nghiên cứu code của anh Ndu rồi và ứng dụng vào các file cụ thể của mình thật tuyệt vời anh ạ tốc độ chạy quá nhanh.
+ Có một vấn đề này nữa không biết có ứng dụng được Consolidate không A nhỉ? em mày mò mãi mà không được. Mong Anh chỉ giúp.
+ Em muốn chỉ lấy dòng dữ liệu tổng của từng file vào file tổng hợp. Như trong file tổng hợp em minh họa.

ndu96081631 · 16/4/11

khoavu87 đã viết:
+ Em đang nghiên cứu code của anh Ndu rồi và ứng dụng vào các file cụ thể của mình thật tuyệt vời anh ạ tốc độ chạy quá nhanh.
+ Có một vấn đề này nữa không biết có ứng dụng được Consolidate không A nhỉ? em mày mò mãi mà không được. Mong Anh chỉ giúp.
+ Em muốn chỉ lấy dòng dữ liệu tổng của từng file vào file tổng hợp. Như trong file tổng hợp em minh họa.

Với yêu cầu này thì đây là lại bài toán khác rồi: Lấy dữ liệu từ 1 file đang đóng (với đường dẫn cho trước)... đâu phải là TỔNG HỢP gì đâu chứ
Bài này cũng có nhiều trên diễn đàn rồi mà bạn

khoavu87 · 16/4/11

ndu96081631 đã viết:
Với yêu cầu này thì đây là lại bài toán khác rồi: Lấy dữ liệu từ 1 file đang đóng (với đường dẫn cho trước)... đâu phải là TỔNG HỢP gì đâu chứ
Bài này cũng có nhiều trên diễn đàn rồi mà bạn

Dạ A Ndu hiểu nhầm ý em rồi ạ. Về cách làm khác thì em vẫn theo cách cũ của em, em làm được rồi, nhưng chẳng ưng ý tẹo nào. Chạy vẫn lâu quá đi mất. trong khi chạy cái code bác làm cái dạng file trên nhanh thế nên thấy khoái em mới hỏi Bác ạ.

PHP:

Sub tonghop()
    Dim i As Byte
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
            'ThisWorkbook.Sheets(3).[e14:r24].ClearContents
    For i = 1 To ThisWorkbook.Sheets(1).Range("h1").Value
        Workbooks.Open ThisWorkbook.Path & "\" & i & ".xls"
        Dim j As Byte
        j = ThisWorkbook.Sheets(1).[D1000].End(xlUp).Row
            ActiveWorkbook.Sheets(1).[B3:E3].Copy
            ThisWorkbook.Sheets(1).Cells(j + 1, 4).PasteSpecial Paste:=xlPasteValues
        ActiveWorkbook.Close False
    Next i
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Vẫn dùng code đầu tiên của em em làm thì chạy hơi lâu.Bác xem có cách nào nhanh hơn đc ko?

ndu96081631 · 16/4/11

khoavu87 đã viết:
Vẫn dùng code đầu tiên của em em làm thì chạy hơi lâu.Bác xem có cách nào nhanh hơn đc ko?

Thì dùng ADO đi, hoặc macro 4 (cũng đã có đăng trên diễn đàn)
ADO đã nói nhiều rồi, ở đây tôi giới thiệu bạn cách dùng macro 4 nhé! Xem tại đây:
http://www.giaiphapexcel.com/forum/showthread.php?39312-D%C3%B9ng-Macro-4-%C4%91%E1%BB%83-l%E1%BA%A5y-d%E1%BB%AF-li%E1%BB%87u-t%E1%BB%AB-1-file-%C4%91ang-%C4%91%C3%B3ng
Code có thể là vầy:

PHP:

Function GetData(sFile As String, sSheet As String, sAddr As String)
  Dim pLink As String, iR As Long, iC As Long, Arr
  If Len(Dir(sFile)) Then
    Arr = Range(sAddr)
    pLink = "'" & Replace(sFile, Dir(sFile), "[" & Dir(sFile) & "]") & sSheet & "'!"
    For iR = 1 To Range(sAddr).Rows.Count
      For iC = 1 To Range(sAddr).Columns.Count
        Arr(iR, iC) = ExecuteExcel4Macro(pLink & Range(sAddr).Cells(iR, iC).Address(, , 2))
      Next iC
    Next iR
    GetData = Arr
  End If
End Function

PHP:

Sub Main()
  Dim Clls As Range, sFile As String
  For Each Clls In Sheet1.Range("C5:C8")
    sFile = ThisWorkbook.Path & "\" & Clls.Value & ".xls"
    Clls.Offset(, 1).Resize(, 4).Value = GetData(sFile, "1", "B3:E3")
  Next
End Sub

khoavu87 · 20/4/11

ndu96081631 đã viết:

Cũng file của bạn, tôi sẽ làm bằng Consolidate đây. Down về tham khảo nha
Code:

PHP:

Sub ConsolMutiFiles(Folder As String, ShName As String, SrcRng As String, lWb As Long, Target As Range)
  Dim Temp As String, Arr, i As Long
  ReDim Arr(1 To 1000)
  Temp = ShName & "'!" & Range(SrcRng).Address(, , 2)
  If Right(Folder, 1) <> "\" Then Folder = Folder & "\"
  ActiveWorkbook.Names.Add "Arr", "=""'" & Folder & "[""&Files(""" & Folder & "*.*"")&""]" & Temp & """"
  Arr = Evaluate("Arr")
  ReDim Preserve Arr(1 To lWb)
  Target.Consolidate Arr, 9, 0, 0
  ActiveWorkbook.Names("Arr").Delete
End Sub

PHP:

Sub Main()
  Dim Folder As String, ShName As String, SrcRng As String, lWb As Long
  Range("A1:E1000").ClearContents
  Folder = ThisWorkbook.Path & "\Source"
  ShName = "1": SrcRng = "A1:D30"
  lWb = Range("H1").Value
  ConsolMutiFiles Folder, ShName, SrcRng, lWb, Range("A1")
End Sub

Anh NDU CHO EM hỏi thêm chút là, khi em sử dụng code này của anh để tên các file trong source phải bắt đầu từ (01,02,03..10,11..) thì nó mới chạy đúng vậy em muốn để tên file này bắt đầu là (1,2,3,...) thì phải chỉnh sửa đoạn trên thế nào anh nhỉ? em nhìn mãi mà chưa biết sửa chỗ nào. MONG anh giúp.

ndu96081631 · 20/4/11

khoavu87 đã viết:
Anh NDU CHO EM hỏi thêm chút là, khi em sử dụng code này của anh để tên các file trong source phải bắt đầu từ (01,02,03..10,11..) thì nó mới chạy đúng vậy em muốn để tên file này bắt đầu là (1,2,3,...) thì phải chỉnh sửa đoạn trên thế nào anh nhỉ? em nhìn mãi mà chưa biết sửa chỗ nào. MONG anh giúp.

Vấn đề ở đây là việc sắp xếp chuổi và số có khác nhau
Ví dụ dãy số: 1, 2, 3, 4, .... , 10, 11, .... 20, 21
Nếu xem dãy là là SỐ thì nó sẽ xếp theo thứ tự trên
Nếu xem dãy này là CHUỔI thì nó sẽ xếp khác: 1, 10, 11,... 19, 2, 20, 21, 3, 4
Mà tên file, dù được đặt theo STT thì nó vẫn được xem là CHUỐI, và nó sẽ được sắp xếp theo cách thứ 2.... Chính vì lẽ đó, nếu không đặt tên file theo cách tôi đã làm thì tôi chẳng biết làm cách nào nữa

khoavu87 · 22/4/11

PHP:

Sub tonghop()
    Dim i As Byte
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
            'ThisWorkbook.Sheets(3).[e14:r24].ClearContents
    For i = 1 To ThisWorkbook.Sheets(1).Range("h1").Value
        Workbooks.Open ThisWorkbook.Path & "\" & i & ".xls"
        Dim j As Byte
        j = ThisWorkbook.Sheets(1).[D1000].End(xlUp).Row
            ActiveWorkbook.Sheets(1).[B3:E3].Copy
            ThisWorkbook.Sheets(1).Cells(j + 1, 4).PasteSpecial Paste:=xlPasteValues
        ActiveWorkbook.Close False
    Next i
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Anh Ndu cho em hỏi chút nữa với dạng bài toán này.
+ Theo như Bác nói vơi tên file bao giờ nó cũng là dạng chuỗi. Với code ơr trên em sẽ mở đc tất cả các file có tên là (1,2,3,4,5...,10,11,12...). Vâyj nếu như em để tên file như của Bác (01,02,03,04,05...,10,11,12...) thì mình phải chỉnh sửa code trên thế nào Bác nhỉ? Em chỉnh nhưng mãi chưa đọc đc

Workbooks.Open ThisWorkbook.Path & "\"& "0" & i & ".xls"

Em chỉnh cái chỗ này thì chỉ đọc đc từ (01,09) còn lại ko đọc được không biết thêm điều kiện gì ở dòng đó nữa . Mong Bác giúp.

ndu96081631 · 22/4/11

khoavu87 đã viết:
PHP:

Sub tonghop() Dim i As Byte Application.ScreenUpdating = False Application.DisplayAlerts = False 'ThisWorkbook.Sheets(3).[e14:r24].ClearContents For i = 1 To ThisWorkbook.Sheets(1).Range("h1").Value Workbooks.Open ThisWorkbook.Path & "\" & i & ".xls" Dim j As Byte j = ThisWorkbook.Sheets(1).[D1000].End(xlUp).Row ActiveWorkbook.Sheets(1).[B3:E3].Copy ThisWorkbook.Sheets(1).Cells(j + 1, 4).PasteSpecial Paste:=xlPasteValues ActiveWorkbook.Close False Next i Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

Anh Ndu cho em hỏi chút nữa với dạng bài toán này.
+ Theo như Bác nói vơi tên file bao giờ nó cũng là dạng chuỗi. Với code ơr trên em sẽ mở đc tất cả các file có tên là (1,2,3,4,5...,10,11,12...). Vâyj nếu như em để tên file như của Bác (01,02,03,04,05...,10,11,12...) thì mình phải chỉnh sửa code trên thế nào Bác nhỉ? Em chỉnh nhưng mãi chưa đọc đc

Em chỉnh cái chỗ này thì chỉ đọc đc từ (01,09) còn lại ko đọc được không biết thêm điều kiện gì ở dòng đó nữa . Mong Bác giúp.

Phải vầy chứ

PHP:

Workbooks.Open ThisWorkbook.Path & "\"& Text(i,"00") & ".xls"

Tối ưu đoạn code tổng hợp các file lại thành một file tổng.

khoavu87

Vũ Trần Khoa

File đính kèm

ndu96081631

Huyền thoại GPE

khoavu87

Vũ Trần Khoa

ndu96081631

Huyền thoại GPE

File đính kèm

khoavu87

Vũ Trần Khoa

File đính kèm

ndu96081631

Huyền thoại GPE

khoavu87

Vũ Trần Khoa

ndu96081631

Huyền thoại GPE

khoavu87

Vũ Trần Khoa

ndu96081631

Huyền thoại GPE

khoavu87

Vũ Trần Khoa

ndu96081631

Huyền thoại GPE

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