Giúp Code Copy data từ các sheet theo Form

[letuvan]

Nhờ các cao nhân chỉ giáo

E cần copy các dữ liệu từ các sheet 1 sheet 2, sheet 3 vào Sheet "Form"

Sheet "Form" đã cố định các cột dữ liệu cần copy từ các sheet 1,2,3. tên các tiêu đề cột các sheet 1,2,3 giống nhau nhưng sắp xếp thứ tự các cột khác nhau

Do data lớn mỗi sheet 30k dòng ( nhiều sheet) nên e dùng công thức rât nặng. Mong các bác chỉ giáo

E gửi kèm theo file đính kèm ạ

E cám ơn

 

[letuvan]

Đây bạn xem nhé.

Sub tonghop()
Dim arr, arr1, arr2, dic As Object, lr As Long, i As Long, j As Integer, dk As String, sh As Worksheet, b As Integer, a As Long, tong As Worksheet
  Application.ScreenUpdating = False
    Set dic = CreateObject("scripting.dictionary")
    Set tong = Sheets("TH")
    With Sheets("TH")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 1 Then .Range("A2:AH" & lr).ClearContents
         For i = 2 To 35
             dic.Item(.Cells(1, i).Value) = i
         Next i
    End With
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "TH" Then
           lr = sh.Range("A8").End(xlDown).Row
           If lr = Rows.Count Then lr = 8
           If sh.Range("a8").Value <> Empty Then
              arr = sh.Range("A8:AH" & lr).Value
              ReDim arr2(1 To 34): b = 0
              ReDim arr1(1 To UBound(arr, 1), 1 To 35): a = 0
              For i = 1 To 36
                  If dic.exists(sh.Cells(6, i).Value) Then
                     b = b + 1
                     arr2(b) = dic.Item(sh.Cells(6, i).Value)
                  End If
              Next i
              For i = 1 To UBound(arr, 1)
                  a = a + 1
                  arr1(a, 1) = sh.Name
                  For j = 1 To b
                      arr1(a, arr2(j)) = arr(i, j)
                  Next j
              Next i
              lr = tong.Range("A" & Rows.Count).End(xlUp).Row + 1
              If a Then tong.Range("A" & lr).Resize(a, 34).Value = arr1
         End If
     End If
  Next
  Application.ScreenUpdating = True
End Sub

Mình check lại thấy các cột copy không đúng dữ liệu, bạn xem giúp mình với nhé,
Các sheet có tên cột giống nhau nhưng thứ tự các cột ko giống nhau, bạn check bất kỳ bôi vàng ở các cột bôi vàng xem giúp mình nhé, nó bị copy sai cột, từ cột AD ( Vi du ở sheet 6, mình có bôi vàng)
Xem hộ mình dữ liệu sheet Form đến cột AJ nhé
Cám ơn bạn nhiều

 

[snow25]

Cám ơn bạn rất nhiều, mình đã chạy thử và thành công
Chúc bạn sức khỏe và nhiều niềm vui

Bạn thay cái code này cho chuẩn nhé.Mình sửa lại 1 ít cho đúng.

Sub tonghop()
Dim arr, arr1, arr2(1 To 36), dic As Object, lr As Long, i As Long, j As Integer, dk As String, sh As Worksheet, b As Integer, a As Long, tong As Worksheet
  Application.ScreenUpdating = False
    Set dic = CreateObject("scripting.dictionary")
    Set tong = Sheets("TH")
    With Sheets("TH")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 1 Then .Range("A2:AH" & lr).ClearContents
         For i = 2 To 36
             dic.Item(.Cells(1, i).Value) = i
         Next i
    End With
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "TH" Then
           lr = sh.Range("A8").End(xlDown).Row
           If lr = Rows.Count Then lr = 8
           If sh.Range("a8").Value <> Empty Then
              arr = sh.Range("A8:Aj" & lr).Value
                 ReDim arr1(1 To UBound(arr, 1), 1 To 36): a = 0
              For i = 1 To 36
                  If dic.exists(sh.Cells(6, i).Value) Then
                     arr2(i) = dic.Item(sh.Cells(6, i).Value)
                  End If
              Next i
              For i = 1 To UBound(arr, 1)
                  a = a + 1
                  arr1(a, 1) = sh.Name
                  For j = 1 To 36
                     If arr2(j) <> Empty Then arr1(a, arr2(j)) = arr(i, j)
                  Next j
              Next i
              Erase arr2
              lr = tong.Range("A" & Rows.Count).End(xlUp).Row + 1
              If a Then tong.Range("A" & lr).Resize(a, 36).Value = arr1
         End If
     End If
  Next
  Application.ScreenUpdating = True
End Sub

 

[letuvan]

Bạn thay cái code này cho chuẩn nhé.Mình sửa lại 1 ít cho đúng.

Sub tonghop()
Dim arr, arr1, arr2(1 To 36), dic As Object, lr As Long, i As Long, j As Integer, dk As String, sh As Worksheet, b As Integer, a As Long, tong As Worksheet
  Application.ScreenUpdating = False
    Set dic = CreateObject("scripting.dictionary")
    Set tong = Sheets("TH")
    With Sheets("TH")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         If lr > 1 Then .Range("A2:AH" & lr).ClearContents
         For i = 2 To 36
             dic.Item(.Cells(1, i).Value) = i
         Next i
    End With
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "TH" Then
           lr = sh.Range("A8").End(xlDown).Row
           If lr = Rows.Count Then lr = 8
           If sh.Range("a8").Value <> Empty Then
              arr = sh.Range("A8:Aj" & lr).Value
                 ReDim arr1(1 To UBound(arr, 1), 1 To 36): a = 0
              For i = 1 To 36
                  If dic.exists(sh.Cells(6, i).Value) Then
                     arr2(i) = dic.Item(sh.Cells(6, i).Value)
                  End If
              Next i
              For i = 1 To UBound(arr, 1)
                  a = a + 1
                  arr1(a, 1) = sh.Name
                  For j = 1 To 36
                     If arr2(j) <> Empty Then arr1(a, arr2(j)) = arr(i, j)
                  Next j
              Next i
              Erase arr2
              lr = tong.Range("A" & Rows.Count).End(xlUp).Row + 1
              If a Then tong.Range("A" & lr).Resize(a, 36).Value = arr1
         End If
     End If
  Next
  Application.ScreenUpdating = True
End Sub

Cám ơn bạn nhiều nhé, mình thấy ok rồi ạh