Xin giúp viết mã VBA gộp dữ liệu từ 2 sheet!

[theanhst92]

Lời đầu tiên cho em xin phép được gửi lời chào đến tất cả mọi người ạ!
Em đang cần dùng mã để gộp dữ liệu tự động cho 2 sheet dữ liệu, mong được mọi người giúp đỡ em với ạ!
Em xin mô tả qua vấn đề như sau:
Hiện tại em có 2 sheet dữ liệu. cả 2 sheet này có cấu trúc giống nhau. giờ em muốn gộp dữ liệu cả 2 sheet này lại vào 1 sheet và tính tổng dữ liệu phát sinh theo điều kiện là ngày, chứng từ và mã hàng.
hy vọng mọi người giúp em với ạ!

 

[HieuCD]

Lời đầu tiên cho em xin phép được gửi lời chào đến tất cả mọi người ạ!
Em đang cần dùng mã để gộp dữ liệu tự động cho 2 sheet dữ liệu, mong được mọi người giúp đỡ em với ạ!
Em xin mô tả qua vấn đề như sau:
Hiện tại em có 2 sheet dữ liệu. cả 2 sheet này có cấu trúc giống nhau. giờ em muốn gộp dữ liệu cả 2 sheet này lại vào 1 sheet và tính tổng dữ liệu phát sinh theo điều kiện là ngày, chứng từ và mã hàng.
hy vọng mọi người giúp em với ạ!

Chạy code

Sub ABC()
  Dim sArr(), Res(), Dic As Object, iNgay, iKey$
  Dim sRow&, i&, k&, iR&, jCol&
 
  For n = 1 To 2
    sRow = sRow + Sheets("DL" & n).Range("I" & Rows.Count).End(xlUp).Row - 3
  Next n
  ReDim Res(1 To sRow, 1 To 9)
  Set Dic = CreateObject("scripting.dictionary")
  jCol = 7
  For n = 1 To 2
    With Sheets("DL" & n)
      sArr = .Range("B5", .Range("I" & Rows.Count).End(xlUp)).Value
    End With
    For i = 1 To UBound(sArr)
      ngay = sArr(i, 1)
      If ngay <> Empty Then
        iKey = Format(sArr(i, 1), "000000") & "|2|" & sArr(i, 2) & "|" & sArr(i, 4)
        If Dic.exists(iKey) = False Then
          k = k + 1
          Dic.Add iKey, k
          For j = 1 To 6
            Res(k, j) = sArr(i, j)
          Next j
          Res(k, 9) = iKey
        End If
        iR = Dic.Item(iKey)
        Res(iR, jCol) = Res(iR, jCol) + sArr(i, 8)
      
        If Dic.exists(ngay) = False Then
          k = k + 1
          Res(k, 9) = Replace(iKey, "|2|", "|1|")
          Dic.Add ngay, ""
        End If
      End If
    Next i
    jCol = jCol + 1
  Next n
  Application.ScreenUpdating = False
  With Sheets("GOP")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i > 4 Then .Range("B5:J" & i).ClearContents
    .Range("B4").Resize(k, 9) = Res
    .Range("B4").Resize(k, 9).Sort .Range("J4"), 1, Header:=xlNo
    .Range("J4").Resize(k).ClearContents
  End With
  Application.ScreenUpdating = True
End Sub

 

[SA_DQ]

Ngoài lề 1 chút: Chủ bài đăng xem nếu có thể áp dụng bộ mã mới như sau (?):

Mã hàng	Tên hàng	Đvt	Quy cách	=>	Mã mới
MH001	Hàng hoá 001	đôi	L	=>	MH001L_
MH001	Hàng hoá 001	đôi	LM	=>	MH001LM
MH001	Hàng hoá 001	đôi	LS	=>	MH001LS
MH001	Hàng hoá 001	đôi	M	=>	MH001M_
MH001	Hàng hoá 001	đôi	ML	=>	MH001ML
MH001	Hàng hoá 001	đôi	MM	=>	MH001MM
MH001	Hàng hoá 001	đôi	MS	=>	MH001MS
MH001	Hàng hoá 001	đôi	S	=>	MH001S_
MH001	Hàng hoá 001	đôi	SL	=>	MH001SL
MH001	Hàng hoá 001	đôi	SS	=>	MH001SS
MH002	Hàng hoá 002	đôi	L	=>	MH002L_
MH002	Hàng hoá 002	đôi	LM	=>	MH002LM
MH002	Hàng hoá 002	đôi	LS	=>	MH002LS
MH002	Hàng hoá 002	đôi	S	=>	MH002S_

 

[theanhst92]

Chạy code

Sub ABC()
  Dim sArr(), Res(), Dic As Object, iNgay, iKey$
  Dim sRow&, i&, k&, iR&, jCol&
 
  For n = 1 To 2
    sRow = sRow + Sheets("DL" & n).Range("I" & Rows.Count).End(xlUp).Row - 3
  Next n
  ReDim Res(1 To sRow, 1 To 9)
  Set Dic = CreateObject("scripting.dictionary")
  jCol = 7
  For n = 1 To 2
    With Sheets("DL" & n)
      sArr = .Range("B5", .Range("I" & Rows.Count).End(xlUp)).Value
    End With
    For i = 1 To UBound(sArr)
      ngay = sArr(i, 1)
      If ngay <> Empty Then
        iKey = Format(sArr(i, 1), "000000") & "|2|" & sArr(i, 2) & "|" & sArr(i, 4)
        If Dic.exists(iKey) = False Then
          k = k + 1
          Dic.Add iKey, k
          For j = 1 To 6
            Res(k, j) = sArr(i, j)
          Next j
          Res(k, 9) = iKey
        End If
        iR = Dic.Item(iKey)
        Res(iR, jCol) = Res(iR, jCol) + sArr(i, 8)
     
        If Dic.exists(ngay) = False Then
          k = k + 1
          Res(k, 9) = Replace(iKey, "|2|", "|1|")
          Dic.Add ngay, ""
        End If
      End If
    Next i
    jCol = jCol + 1
  Next n
  Application.ScreenUpdating = False
  With Sheets("GOP")
    i = .Range("B" & Rows.Count).End(xlUp).Row
    If i > 4 Then .Range("B5:J" & i).ClearContents
    .Range("B4").Resize(k, 9) = Res
    .Range("B4").Resize(k, 9).Sort .Range("J4"), 1, Header:=xlNo
    .Range("J4").Resize(k).ClearContents
  End With
  Application.ScreenUpdating = True
End Sub

em cảm ơn bác. để em chạy thử ạ!