Code xắp xếp cột khi gộp nhiều Sheets ? (1 người xem)

[TrungChinhs]

Nhờ các bạn tư vấn giúp mình code hoặc phương pháp xắp xếp cột khi gộp nhiều Sheets vào Sheet tổng.
Về code gộp hoặc nối Sheet mình đã biết. Vấn đề ở đây là làm thế nào để khi gộp Sheet các cột được đặt đúng vị trí trong bảng tổng. Lâu nay mình phương pháp Copy từng cột nhưng do có hàng trăm Sheet nên code chạy rất chậm. Mình nghĩ dùng phương pháp Sort Column có thể nhanh hơn nhưng chưa biết làm thế nào để Sort được các cột về đúng vị trí của bảng tổng ?

Kết quả mong muốn như sheet Tong Hop trong file đính kèm.

 

[ndu96081631]

Nhờ các bạn tư vấn giúp mình code hoặc phương pháp xắp xếp cột khi gộp nhiều Sheets vào Sheet tổng.
Về code gộp hoặc nối Sheet mình đã biết. Vấn đề ở đây là làm thế nào để khi gộp Sheet các cột được đặt đúng vị trí trong bảng tổng. Lâu nay mình phương pháp Copy từng cột nhưng do có hàng trăm Sheet nên code chạy rất chậm. Mình nghĩ dùng phương pháp Sort Column có thể nhanh hơn nhưng chưa biết làm thế nào để Sort được các cột về đúng vị trí của bảng tổng ?

Kết quả mong muốn như sheet Tong Hop trong file đính kèm.

Hỏi lại:
- Trong các sheet con, dữ liệu nằm ở đâu tùy ý hả anh?
- Ý em muốn nói nếu em dùng UsedRange để định vị dữ liệu thì có vấn đề gì không?

 

[TrungChinhs]

Hỏi lại:
- Trong các sheet con, dữ liệu nằm ở đâu tùy ý hả anh?
- Ý em muốn nói nếu em dùng UsedRange để định vị dữ liệu thì có vấn đề gì không?

Đúng vậy em à. Dữ liệu do nhiều người lập nên vùng dữ liệu không cố định và số cột thì Sheet ít, Sheet nhiều và không theo thứ tự.
Dùng UsedRange cũng được miễn là làm sao sort được cột theo yêu cầu.

 

[PhanTuHuong]

Theo ý bác TrungChinh là copy các tên cột tương ứng từng trong từng sheet (sắp xếp lộn xộn) và sheet Tonghop theo thứ tự quy định phải không?

Nếu như vậy ta dùng trình duyệt từng sheet, sau đó xác định vùng dữ liệu bằng UsedRange. Xác định từng tên cột để copy sang khi thỏa mãn... Em hỏi thêm là tại các sheet đơn lẻ, các cột có xếp sát nhau giống như trường hợp bác up lên không?

 

[TrungChinhs]

Theo ý bác TrungChinh là copy các tên cột tương ứng từng trong từng sheet (sắp xếp lộn xộn) và sheet Tonghop theo thứ tự quy định phải không?

Nếu như vậy ta dùng trình duyệt từng sheet, sau đó xác định vùng dữ liệu bằng UsedRange. Xác định từng tên cột để copy sang khi thỏa mãn... Em hỏi thêm là tại các sheet đơn lẻ, các cột có xếp sát nhau giống như trường hợp bác up lên không?

@ Hướng: Đúng là trong từng Sheet thì cột sắp xếp lộn xộn và xếp sát nhau. Cách làm như trên thì mình đã làm rồi và như đã nói ở bài 1, mình nghĩ dùng phương pháp sort column để đưa cột về đúng chỗ chắc sẽ nhanh hơn nhiều (không biết có đúng không ?) nhưng do đang bí về việc điền số thứ tự vào đầu cột để sort nên mới post bài nhờ mọi người giúp.

 

[ndu96081631]

Thử code vầy xem:

Sub Main()
  Dim tmpArr, Arr()
  Dim lR As Long, lC As Long, lCs As Long, i As Long, n As Long, lCPos As Long
  Dim wks As Worksheet, wksDes As Worksheet, Dic As Object
  Dim sTitle As String
  On Error Resume Next
  Set Dic = CreateObject("Scripting.Dictionary")
  Set wksDes = Worksheets("Tong hop")
  wksDes.UsedRange.ClearContents
  ReDim Arr(1 To 60000, 1 To 1)
  For Each wks In ThisWorkbook.Worksheets
    If UCase(wks.Name) <> UCase(wksDes.Name) Then
      tmpArr = wks.UsedRange.Value
      If TypeName(tmpArr) = "Variant()" Then
        n = n + 1
        For lR = 2 To UBound(tmpArr, 1)
          n = n + 1
          For lC = 1 To UBound(tmpArr, 2)
            sTitle = Trim(CStr(tmpArr(1, lC)))
            If Len(sTitle) Then
              If Not Dic.Exists(sTitle) Then
                lCs = lCs + 1
                Dic.Add sTitle, lCs
                If UBound(Arr, 2) < lCs Then ReDim Preserve Arr(1 To 60000, 1 To lCs)
                Arr(1, lCs) = sTitle
                Arr(n, lCs) = tmpArr(lR, lC)
              Else
                lCPos = Dic.Item(sTitle)
                Arr(n, lCPos) = tmpArr(lR, lC)
              End If
            End If
          Next lC
        Next lR
      End If
    End If
  Next wks
  If n * lCs Then
    With wksDes.Range("A3").Resize(n, lCs)
      .Value = Arr
      .Sort .Rows(1), 1, , , , , , xlYes, , , xlLeftToRight
    End With
  End If
End Sub

Em cũng không chắc lắm nhưng anh cứ thử! Có gì trục trặc ta sẽ bàn tiếp

 

[Ba Tê]

Nếu tiêu đề các sheet con có số cột thì xin góp 1 code "củ chuối":

Public Sub XEPCOT()
Dim WS As Worksheet, I As Long, J As Long, K As Long, Rng(), Arr(1 To 10000, 1 To 10), Cot As Long
For Each WS In Worksheets
    If WS.Name <> "Tong hop" Then
        Rng = WS.UsedRange.Value
        K = K + 1
        For I = 1 To 10
            Arr(K, I) = "Cot " & I
        Next I
        For I = 2 To UBound(Rng, 1)
            K = K + 1
            For J = 1 To UBound(Rng, 2)
                Cot = 1 * (Mid(Rng(1, J), 5, 2))
                Arr(K, Cot) = Rng(I, J)
            Next J
        Next I
        K = K + 1
    End If
Next
With Sheets("Tong hop")
    .[A3:J10000].ClearContents
    .[A3].Resize(K, 10).Value = Arr
End With
End Sub

 

[TrungChinhs]

Em cũng không chắc lắm nhưng anh cứ thử! Có gì trục trặc ta sẽ bàn tiếp

Cảm ơn Ndu! Với file ví dụ thì OK rồi, tốc độ cực khủng, mình đã test với 10 sh, tổng cộng hơn 20.000 dòng nhưng kết quả gần như tức thì. Nhưng việc Sort vẫn chưa ổn ở chỗ thứ tự n đến n* trước n+1. vd: cột 1, cột 10 , cột 2.

 

[ndu96081631]

Nhưng việc Sort vẫn chưa ổn ở chỗ thứ tự n đến n* trước n+1. vd: cột 1, cột 10 , cột 2.

Đương nhiên rồi anh! Excel nó vậy thôi
Nếu anh ghi Cột 01, Cột 02, Cột 03.... Cột 10, Cột 11 thì sẽ không có vấn đề
Còn ghi như anh hiện giờ, Excel sẽ sort kiểu Text: Cột 1, Cột 10, Cột 2, Cột 3, Cột 30...

 

[TrungChinhs]

Nếu tiêu đề các sheet con có số cột thì xin góp 1 code "củ chuối":

Public Sub XEPCOT()
Dim WS As Worksheet, I As Long, J As Long, K As Long, Rng(), Arr(1 To 10000, 1 To 10), Cot As Long
For Each WS In Worksheets
    If WS.Name <> "Tong hop" Then
        Rng = WS.UsedRange.Value
        K = K + 1
        For I = 1 To 10
            Arr(K, I) = "Cot " & I
        Next I
        For I = 2 To UBound(Rng, 1)
            K = K + 1
            For J = 1 To UBound(Rng, 2)
                Cot = 1 * (Mid(Rng(1, J), 5, 2))
                Arr(K, Cot) = Rng(I, J)
            Next J
        Next I
        K = K + 1
    End If
Next
With Sheets("Tong hop")
    .[A3:J10000].ClearContents
    .[A3].Resize(K, 10).Value = Arr
End With
End Sub

@ Ba Tê: có phải "củ chuối" đâu ? cái này là "Pâté - Ba Tê" mới đúng.
Thực tế thì tên cột làm gì có số nhưng không sao, cái mình cần là cách giải quyết, mà nếu cần có số thì ta cứ đưa vào làm xong thì lại rút ra có sao đâu. ẹc...ẹc...
Cách này không cần phải Sort Column và tốc độ cũng rất nhanh, khỏi cần Copy paste từng cột.
Cảm ơn bạn rất nhiều về sự giúp đỡ này.

 

[Quang_Hải]

Viết xong code thì đọc code của anh NDU và của anh Bate thấy mắc cở cho code của mình quá nhưng thôi cũng đưa lên cho các anh góp ý dùm

 

[ndu96081631]

Viết xong code thì đọc code của anh NDU và của anh Bate thấy mắc cở cho code của mình quá nhưng thôi cũng đưa lên cho các anh góp ý dùm

Mắc cở quỷ gì chứ ---> Cái nào cũng là học thuật, cũng phải suy nghĩ mới ra đồng chí à!
Vậy nên: BÔNG HOA NÀO CŨNG QUÝ CŨNG THƠM
Ẹc... Ẹc...

 

[TrungChinhs]

Trước hết tôi xin cảm ơn sự giúp đỡ của các bạn. Thực tế thì tôi đang tổng hợp số liệu đất đai từ các file thôn bản về file xã vì vậy tên cột là các Mã hiệu đất chứ không có số như ví dụ, đầu biểu có Merge Cel (kiểu như đầu bảng chấm công), các file thì có số cột khác nhau và xếp không theo thứ tự, mỗi file có thể có 1 hoặc nhiều sheet, mỗi biểu thì chỉ có khoảng 10 cột nhưng khi tổng hợp thì biểu tổng có thể lên tới 60 cột... Nhìn chung là khá phức tạp. Nay được sự giúp đỡ của các bạn, hướng giải quyết vấn đề đã được gợi mở, tôi sẽ tiếp tục nghiên cứu để ứng dụng vào thực tế công việc của mình. Nếu còn vướng mắc gì thì lại tiếp tục nhờ các bạn.

 

[TrungChinhs]

Nhờ dịchcode !

Vừa rồi bạn ndu đã viết giúp tôi doạn code này và tôi đã áp dụng thành công vào công việc của mình nhưng thực sự tôi không hiểu lắm về thuật giải...Tôi đã đánh vật với nó mấy ngày nay nhưng vẫn thấy mung lung quá, đành phải nhờ các bạn dịch giúp đoạn code này (đoạn tô đỏ). Xin chân thành cảm ơn !

Sub Main()
  Dim tmpArr, Arr()
  Dim lR As Long, lC As Long, lCs As Long, i As Long, n As Long, lCPos As Long
  Dim wks As Worksheet, wksDes As Worksheet, Dic As Object
  Dim sTitle As String
  On Error Resume Next
  Set Dic = CreateObject("Scripting.Dictionary")
  Set wksDes = Worksheets("Tong hop")
  wksDes.UsedRange.ClearContents
  ReDim Arr(1 To 60000, 1 To 1)
  For Each wks In ThisWorkbook.Worksheets
    If UCase(wks.Name) <> UCase(wksDes.Name) Then
      tmpArr = wks.UsedRange.Value
     [COLOR=#ff0000] If TypeName(tmpArr) = "Variant()" Then
        n = n + 1
        For lR = 2 To UBound(tmpArr, 1)
          n = n + 1
          For lC = 1 To UBound(tmpArr, 2)
            sTitle = Trim(CStr(tmpArr(1, lC)))
            If Len(sTitle) Then
              If Not Dic.Exists(sTitle) Then
                lCs = lCs + 1
                Dic.Add sTitle, lCs
                If UBound(Arr, 2) < lCs Then ReDim Preserve Arr(1 To 60000, 1 To lCs)
                Arr(1, lCs) = sTitle
                Arr(n, lCs) = tmpArr(lR, lC)
              Else
                lCPos = Dic.Item(sTitle)
                Arr(n, lCPos) = tmpArr(lR, lC)
              End If
            End If
          Next lC
        Next lR
      End If
    End If
  Next wks[/COLOR]
  If n * lCs Then
    With wksDes.Range("A3").Resize(n, lCs)
      .Value = Arr
      .Sort .Rows(1), 1, , , , , , xlYes, , , xlLeftToRight
    End With
  End If
End Sub