Chuyển đổi định dạng bảng biểu

Liên hệ QC
soledad_90 đã viết:
Muốn làm được các trường dữ liệu dánh dấu này bắt buộc cần phải thiết lập phải không ạ
Nhấp chuột vào đây để mở rộng...
Làm pivot thì các cột phụ đấy cần phải có (không dùng cột phụ thì mình không biết), lọc ra theo yêu cầu bảng biểu của mình thôi, cần hiểu để chỉnh công thức cột phụ cho phù hợp yêu cầu.
 
soledad_90 đã viết:
eM ĐÃ cho chạy code.
Kết quả hiện thị có sự ngược : Cột Đôi thể hiện số lượng của giá trị thùng / cột thùng thể hiện giá trị của đôi.
Và Số S0 224547B / có các màu WAY / 244/T25 số lượng chuyển đổi sai so với dữ liệu gốc PKL.
Anh kiểm tra code ạ
View attachment 257130
Nhấp chuột vào đây để mở rộng...
Chỉnh lại tổng quát hơn
Không được xóa 2 ô I1:J1 sheet Bienban, có thể format lại theo ý thích
Mã: 
Sub XYZ()
  Dim sArr(), Arr(), aSize(), tArr(), Res(), Dic As Object, iKey$
  Dim sRow&, sCol&, scolSize&, maxSize&
  Dim fR&, i&, j&, iR&, n&, k&
  Dim tmp, tDH$, soDH$, iCode$, TT#, TT2#
 
  Set Dic = CreateObject("scripting.dictionary")
  With Sheets("PKL")
    For j = 10 To 100
      If .Cells(7, j) = "PRS" Then sCol = j: Exit For
    Next j
    sArr = .Range("A7", .Cells(.Range("D" & Rows.Count).End(xlUp).Row, sCol)).Value
  End With
  sRow = UBound(sArr)
  scolSize = sCol - 3 'So cot mang Size
  ReDim aSize(1 To 1, 6 To scolSize)
  ReDim tArr(1 To 4)
  ReDim Arr(1 To 100, 1 To 2)
  Arr = Array(Arr, Arr, tArr, aSize)
  For i = 2 To sRow
    tmp = sArr(i, 1)
    If InStr(1, tmp, ")/") > 0 Then
      soDH = Trim(Split(Split(tmp, "(")(1), ")")(0))
      iCode = Trim(Split(tmp, ":")(1))
      If Dic.exists(soDH) = False Then
        k = k + 1
        Dic.Add soDH, k
        ReDim Preserve Res(1 To k)
        Res(k) = Arr
        Res(k)(2)(3) = soDH '(3) So Don Hang
        For j = 6 To scolSize
          Res(k)(3)(1, j) = sArr(i - 1, j)
          If sArr(i - 1, j) <> Empty Then
            If maxSize < j - 5 Then maxSize = j - 5
          End If
        Next j
      End If
    ElseIf tmp <> Empty And IsNumeric(tmp) Then
      n = Dic.Item(soDH)
      iKey = soDH & "|" & iCode & "|" & sArr(i, 4)
      If Dic.exists(iKey) = False Then
        iR = Res(n)(2)(4) + 1 '(4) So dong ket qua
        Res(n)(2)(4) = iR
        Dic.Add iKey, iR
        Res(n)(0)(iR, 1) = iCode: Res(n)(0)(iR, 2) = sArr(i, 4)
      End If
      
      iR = Dic.Item(iKey)
      Res(n)(1)(iR, 1) = Res(n)(1)(iR, 1) + sArr(i, 28) 'so Doi
      Res(n)(1)(iR, 2) = Res(n)(1)(iR, 2) + sArr(i, 27) 'so Thung
      
      Res(n)(2)(1) = Res(n)(2)(1) + sArr(i, 28) 'Tong so Doi
      Res(n)(2)(2) = Res(n)(2)(1) + sArr(i, 27) 'Tong so Thung
      TT = TT + sArr(i, 28):    TT2 = TT2 + sArr(i, 27)
    End If
  Next i
 
  Application.ScreenUpdating = False
  fR = 1
  With Sheets("BienBan")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("A2:Z" & i).Clear
    If maxSize < 11 Then maxSize = 11
    For n = 1 To k
      sRow = Res(n)(2)(4)
      .Range("I1:J1").Copy .Range("I" & fR) 'Tieu de va So Don Hang"
      .Range("J" & fR) = Res(n)(2)(3) 'so Don Hang
      .Range("A" & fR + 1) = "STYLECODE"
      .Range("B" & fR + 1) = "COLOR"
      .Range("A" & fR + 1).Offset(, maxSize + 2) = "PRS"
      .Range("B" & fR + 1).Offset(, maxSize + 2) = "Carton"
      .Range("C" & fR + 1).Resize(, maxSize) = Res(n)(3)
      .Range("A" & fR + 2).Resize(sRow, 2) = Res(n)(0)
      .Range("A" & fR + 2).Offset(, maxSize + 2).Resize(sRow, 2) = Res(n)(1)
      .Range("A" & fR + sRow + 2) = "Total"
      .Range("A" & fR + sRow + 2).Offset(, maxSize + 2) = Res(n)(2)(1)
      .Range("B" & fR + sRow + 2).Offset(, maxSize + 2) = Res(n)(2)(2)
      .Range("A" & fR + sRow + 2).Resize(, maxSize + 2).Merge
      .Range("A" & fR + sRow + 2).Resize(, maxSize + 2).HorizontalAlignment = xlCenter
      .Range("A" & fR + 1).Resize(sRow + 2, maxSize + 4).Borders.LineStyle = 1
      
      fR = fR + sRow + 3
    Next n
    .Range("A" & fR) = "Grand Total"
    .Range("A" & fR).Offset(, maxSize + 2) = TT
    .Range("B" & fR).Offset(, maxSize + 2) = TT2
    .Range("A" & fR).Resize(, maxSize + 2).Merge
    .Range("A" & fR).Resize(, maxSize + 2).HorizontalAlignment = xlCenter
    .Range("A" & fR).Resize(, maxSize + 4).Borders.LineStyle = 1
  End With
  Application.ScreenUpdating = True
End Sub
 

File đính kèm

HieuCD đã viết:
Chỉnh lại tổng quát hơn
Không được xóa 2 ô I1:J1 sheet Bienban, có thể format lại theo ý thích
Mã: 
Sub XYZ()
  Dim sArr(), Arr(), aSize(), tArr(), Res(), Dic As Object, iKey$
  Dim sRow&, sCol&, scolSize&, maxSize&
  Dim fR&, i&, j&, iR&, n&, k&
  Dim tmp, tDH$, soDH$, iCode$, TT#, TT2#

  Set Dic = CreateObject("scripting.dictionary")
  With Sheets("PKL")
    For j = 10 To 100
      If .Cells(7, j) = "PRS" Then sCol = j: Exit For
    Next j
    sArr = .Range("A7", .Cells(.Range("D" & Rows.Count).End(xlUp).Row, sCol)).Value
  End With
  sRow = UBound(sArr)
  scolSize = sCol - 3 'So cot mang Size
  ReDim aSize(1 To 1, 6 To scolSize)
  ReDim tArr(1 To 4)
  ReDim Arr(1 To 100, 1 To 2)
  Arr = Array(Arr, Arr, tArr, aSize)
  For i = 2 To sRow
    tmp = sArr(i, 1)
    If InStr(1, tmp, ")/") > 0 Then
      soDH = Trim(Split(Split(tmp, "(")(1), ")")(0))
      iCode = Trim(Split(tmp, ":")(1))
      If Dic.exists(soDH) = False Then
        k = k + 1
        Dic.Add soDH, k
        ReDim Preserve Res(1 To k)
        Res(k) = Arr
        Res(k)(2)(3) = soDH '(3) So Don Hang
        For j = 6 To scolSize
          Res(k)(3)(1, j) = sArr(i - 1, j)
          If sArr(i - 1, j) <> Empty Then
            If maxSize < j - 5 Then maxSize = j - 5
          End If
        Next j
      End If
    ElseIf tmp <> Empty And IsNumeric(tmp) Then
      n = Dic.Item(soDH)
      iKey = soDH & "|" & iCode & "|" & sArr(i, 4)
      If Dic.exists(iKey) = False Then
        iR = Res(n)(2)(4) + 1 '(4) So dong ket qua
        Res(n)(2)(4) = iR
        Dic.Add iKey, iR
        Res(n)(0)(iR, 1) = iCode: Res(n)(0)(iR, 2) = sArr(i, 4)
      End If
     
      iR = Dic.Item(iKey)
      Res(n)(1)(iR, 1) = Res(n)(1)(iR, 1) + sArr(i, 28) 'so Doi
      Res(n)(1)(iR, 2) = Res(n)(1)(iR, 2) + sArr(i, 27) 'so Thung
     
      Res(n)(2)(1) = Res(n)(2)(1) + sArr(i, 28) 'Tong so Doi
      Res(n)(2)(2) = Res(n)(2)(1) + sArr(i, 27) 'Tong so Thung
      TT = TT + sArr(i, 28):    TT2 = TT2 + sArr(i, 27)
    End If
  Next i

  Application.ScreenUpdating = False
  fR = 1
  With Sheets("BienBan")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("A2:Z" & i).Clear
    If maxSize < 11 Then maxSize = 11
    For n = 1 To k
      sRow = Res(n)(2)(4)
      .Range("I1:J1").Copy .Range("I" & fR) 'Tieu de va So Don Hang"
      .Range("J" & fR) = Res(n)(2)(3) 'so Don Hang
      .Range("A" & fR + 1) = "STYLECODE"
      .Range("B" & fR + 1) = "COLOR"
      .Range("A" & fR + 1).Offset(, maxSize + 2) = "PRS"
      .Range("B" & fR + 1).Offset(, maxSize + 2) = "Carton"
      .Range("C" & fR + 1).Resize(, maxSize) = Res(n)(3)
      .Range("A" & fR + 2).Resize(sRow, 2) = Res(n)(0)
      .Range("A" & fR + 2).Offset(, maxSize + 2).Resize(sRow, 2) = Res(n)(1)
      .Range("A" & fR + sRow + 2) = "Total"
      .Range("A" & fR + sRow + 2).Offset(, maxSize + 2) = Res(n)(2)(1)
      .Range("B" & fR + sRow + 2).Offset(, maxSize + 2) = Res(n)(2)(2)
      .Range("A" & fR + sRow + 2).Resize(, maxSize + 2).Merge
      .Range("A" & fR + sRow + 2).Resize(, maxSize + 2).HorizontalAlignment = xlCenter
      .Range("A" & fR + 1).Resize(sRow + 2, maxSize + 4).Borders.LineStyle = 1
     
      fR = fR + sRow + 3
    Next n
    .Range("A" & fR) = "Grand Total"
    .Range("A" & fR).Offset(, maxSize + 2) = TT
    .Range("B" & fR).Offset(, maxSize + 2) = TT2
    .Range("A" & fR).Resize(, maxSize + 2).Merge
    .Range("A" & fR).Resize(, maxSize + 2).HorizontalAlignment = xlCenter
    .Range("A" & fR).Resize(, maxSize + 4).Borders.LineStyle = 1
  End With
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Em chào anh và diễn đàn ! Chúc anh và diễn đàn một ngày mới đầy năng lượng.

Em có kiểm tra kết quả, về hiển thị chi tiết các S0/mã hàng/màu sắc và size số thì đúng rồi ạ
Nhưng có mục số đôi và số thùng đang bị hiển thị nhầm lẫn qua nhau ạ, hình ảnh em có chú thích ạ
Anh kiểm tra code lại giúp em với ạ
Em cảm ơn!
1618535106267.png
 
soledad_90 đã viết:
Em chào anh và diễn đàn ! Chúc anh và diễn đàn một ngày mới đầy năng lượng.

Em có kiểm tra kết quả, về hiển thị chi tiết các S0/mã hàng/màu sắc và size số thì đúng rồi ạ
Nhưng có mục số đôi và số thùng đang bị hiển thị nhầm lẫn qua nhau ạ, hình ảnh em có chú thích ạ
Anh kiểm tra code lại giúp em với ạ
Em cảm ơn!
View attachment 257152
Nhấp chuột vào đây để mở rộng...
Chỉnh lại
Mã: 
Sub XYZ()
  Dim sArr(), Arr(), aSize(), tArr(), Res(), Dic As Object, iKey$
  Dim sRow&, sCol&, scolSize&, maxSize&
  Dim fR&, i&, j&, iR&, n&, k&
  Dim tmp, tDH$, soDH$, iCode$, TT#, TT2#
 
  Set Dic = CreateObject("scripting.dictionary")
  With Sheets("PKL")
    For j = 10 To 100
      If .Cells(7, j) = "PRS" Then sCol = j: Exit For
    Next j
    sArr = .Range("A7", .Cells(.Range("D" & Rows.Count).End(xlUp).Row, sCol)).Value
  End With
  sRow = UBound(sArr)
  scolSize = sCol - 3 'So cot mang Size
  ReDim aSize(1 To 1, 6 To scolSize)
  ReDim tArr(1 To 4)
  ReDim Arr(1 To 100, 1 To 2)
  Arr = Array(Arr, Arr, tArr, aSize)
  For i = 2 To sRow
    tmp = sArr(i, 1)
    If InStr(1, tmp, ")/") > 0 Then
      soDH = Trim(Split(Split(tmp, "(")(1), ")")(0))
      iCode = Trim(Split(tmp, ":")(1))
      If Dic.exists(soDH) = False Then
        k = k + 1
        Dic.Add soDH, k
        ReDim Preserve Res(1 To k)
        Res(k) = Arr
        Res(k)(2)(3) = soDH '(3) So Don Hang
        For j = 6 To scolSize
          Res(k)(3)(1, j) = sArr(i - 1, j)
          If sArr(i - 1, j) <> Empty Then
            If maxSize < j - 5 Then maxSize = j - 5
          End If
        Next j
      End If
    ElseIf tmp <> Empty And IsNumeric(tmp) Then
      n = Dic.Item(soDH)
      iKey = soDH & "|" & iCode & "|" & sArr(i, 4)
      If Dic.exists(iKey) = False Then
        iR = Res(n)(2)(4) + 1 '(4) So dong ket qua
        Res(n)(2)(4) = iR
        Dic.Add iKey, iR
        Res(n)(0)(iR, 1) = iCode: Res(n)(0)(iR, 2) = sArr(i, 4)
      End If
      iR = Dic.Item(iKey)
      Res(n)(1)(iR, 1) = Res(n)(1)(iR, 1) + sArr(i, sCol) 'so Doi
      Res(n)(1)(iR, 2) = Res(n)(1)(iR, 2) + sArr(i, sCol - 1) 'so Thung
      
      Res(n)(2)(1) = Res(n)(2)(1) + sArr(i, sCol) 'Tong so Doi
      Res(n)(2)(2) = Res(n)(2)(2) + sArr(i, sCol - 1) 'Tong so Thung
      TT = TT + sArr(i, sCol):    TT2 = TT2 + sArr(i, sCol - 1)
    End If
  Next i
 
  Application.ScreenUpdating = False
  fR = 1
  With Sheets("BienBan")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("A2:Z" & i).Clear
    'If maxSize < 11 Then maxSize = 11
    For n = 1 To k
      sRow = Res(n)(2)(4)
      .Range("I1:J1").Copy .Range("I" & fR) 'Tieu de va So Don Hang"
      .Range("J" & fR) = Res(n)(2)(3) 'so Don Hang
      .Range("A" & fR + 1) = "STYLECODE"
      .Range("B" & fR + 1) = "COLOR"
      .Range("A" & fR + 1).Offset(, maxSize + 2) = "PRS"
      .Range("B" & fR + 1).Offset(, maxSize + 2) = "Carton"
      .Range("C" & fR + 1).Resize(, maxSize) = Res(n)(3)
      .Range("A" & fR + 2).Resize(sRow, 2) = Res(n)(0)
      .Range("A" & fR + 2).Offset(, maxSize + 2).Resize(sRow, 2) = Res(n)(1)
      .Range("A" & fR + sRow + 2) = "Total"
      .Range("A" & fR + sRow + 2).Offset(, maxSize + 2) = Res(n)(2)(1)
      .Range("B" & fR + sRow + 2).Offset(, maxSize + 2) = Res(n)(2)(2)
      .Range("A" & fR + sRow + 2).Resize(, maxSize + 2).Merge
      .Range("A" & fR + sRow + 2).Resize(, maxSize + 2).HorizontalAlignment = xlCenter
      .Range("A" & fR + 1).Resize(sRow + 2, maxSize + 4).Borders.LineStyle = 1
      
      fR = fR + sRow + 3
    Next n
    .Range("A" & fR) = "Grand Total"
    .Range("A" & fR).Offset(, maxSize + 2) = TT
    .Range("B" & fR).Offset(, maxSize + 2) = TT2
    .Range("A" & fR).Resize(, maxSize + 2).Merge
    .Range("A" & fR).Resize(, maxSize + 2).HorizontalAlignment = xlCenter
    .Range("A" & fR).Resize(, maxSize + 4).Borders.LineStyle = 1
  End With
  Application.ScreenUpdating = True
End Sub
 
HieuCD đã viết:
Chỉnh lại
Mã: 
Sub XYZ()
  Dim sArr(), Arr(), aSize(), tArr(), Res(), Dic As Object, iKey$
  Dim sRow&, sCol&, scolSize&, maxSize&
  Dim fR&, i&, j&, iR&, n&, k&
  Dim tmp, tDH$, soDH$, iCode$, TT#, TT2#

  Set Dic = CreateObject("scripting.dictionary")
  With Sheets("PKL")
    For j = 10 To 100
      If .Cells(7, j) = "PRS" Then sCol = j: Exit For
    Next j
    sArr = .Range("A7", .Cells(.Range("D" & Rows.Count).End(xlUp).Row, sCol)).Value
  End With
  sRow = UBound(sArr)
  scolSize = sCol - 3 'So cot mang Size
  ReDim aSize(1 To 1, 6 To scolSize)
  ReDim tArr(1 To 4)
  ReDim Arr(1 To 100, 1 To 2)
  Arr = Array(Arr, Arr, tArr, aSize)
  For i = 2 To sRow
    tmp = sArr(i, 1)
    If InStr(1, tmp, ")/") > 0 Then
      soDH = Trim(Split(Split(tmp, "(")(1), ")")(0))
      iCode = Trim(Split(tmp, ":")(1))
      If Dic.exists(soDH) = False Then
        k = k + 1
        Dic.Add soDH, k
        ReDim Preserve Res(1 To k)
        Res(k) = Arr
        Res(k)(2)(3) = soDH '(3) So Don Hang
        For j = 6 To scolSize
          Res(k)(3)(1, j) = sArr(i - 1, j)
          If sArr(i - 1, j) <> Empty Then
            If maxSize < j - 5 Then maxSize = j - 5
          End If
        Next j
      End If
    ElseIf tmp <> Empty And IsNumeric(tmp) Then
      n = Dic.Item(soDH)
      iKey = soDH & "|" & iCode & "|" & sArr(i, 4)
      If Dic.exists(iKey) = False Then
        iR = Res(n)(2)(4) + 1 '(4) So dong ket qua
        Res(n)(2)(4) = iR
        Dic.Add iKey, iR
        Res(n)(0)(iR, 1) = iCode: Res(n)(0)(iR, 2) = sArr(i, 4)
      End If
      iR = Dic.Item(iKey)
      Res(n)(1)(iR, 1) = Res(n)(1)(iR, 1) + sArr(i, sCol) 'so Doi
      Res(n)(1)(iR, 2) = Res(n)(1)(iR, 2) + sArr(i, sCol - 1) 'so Thung
     
      Res(n)(2)(1) = Res(n)(2)(1) + sArr(i, sCol) 'Tong so Doi
      Res(n)(2)(2) = Res(n)(2)(2) + sArr(i, sCol - 1) 'Tong so Thung
      TT = TT + sArr(i, sCol):    TT2 = TT2 + sArr(i, sCol - 1)
    End If
  Next i

  Application.ScreenUpdating = False
  fR = 1
  With Sheets("BienBan")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("A2:Z" & i).Clear
    'If maxSize < 11 Then maxSize = 11
    For n = 1 To k
      sRow = Res(n)(2)(4)
      .Range("I1:J1").Copy .Range("I" & fR) 'Tieu de va So Don Hang"
      .Range("J" & fR) = Res(n)(2)(3) 'so Don Hang
      .Range("A" & fR + 1) = "STYLECODE"
      .Range("B" & fR + 1) = "COLOR"
      .Range("A" & fR + 1).Offset(, maxSize + 2) = "PRS"
      .Range("B" & fR + 1).Offset(, maxSize + 2) = "Carton"
      .Range("C" & fR + 1).Resize(, maxSize) = Res(n)(3)
      .Range("A" & fR + 2).Resize(sRow, 2) = Res(n)(0)
      .Range("A" & fR + 2).Offset(, maxSize + 2).Resize(sRow, 2) = Res(n)(1)
      .Range("A" & fR + sRow + 2) = "Total"
      .Range("A" & fR + sRow + 2).Offset(, maxSize + 2) = Res(n)(2)(1)
      .Range("B" & fR + sRow + 2).Offset(, maxSize + 2) = Res(n)(2)(2)
      .Range("A" & fR + sRow + 2).Resize(, maxSize + 2).Merge
      .Range("A" & fR + sRow + 2).Resize(, maxSize + 2).HorizontalAlignment = xlCenter
      .Range("A" & fR + 1).Resize(sRow + 2, maxSize + 4).Borders.LineStyle = 1
     
      fR = fR + sRow + 3
    Next n
    .Range("A" & fR) = "Grand Total"
    .Range("A" & fR).Offset(, maxSize + 2) = TT
    .Range("B" & fR).Offset(, maxSize + 2) = TT2
    .Range("A" & fR).Resize(, maxSize + 2).Merge
    .Range("A" & fR).Resize(, maxSize + 2).HorizontalAlignment = xlCenter
    .Range("A" & fR).Resize(, maxSize + 4).Borders.LineStyle = 1
  End With
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh rất nhiều, đã theo topic này tới kết quả cuối cùng ạ.
Code chạy tốt với các yêu cầu thêm mà em yêu cầu rồi ạ.
Do Biên bản này em cần thêm nhiều thông tin khác theo mẫu sẵn : Nên nhờ anh chỉnh lại code kết quả tại sheet BienBan
Chỉ hiện thị kết quả từ cột A tới cột O ( cột N thể hiện số đôi, cột O thể hiện số thùng ).

1618553423605.png
 
soledad_90 đã viết:
Cảm ơn anh rất nhiều, đã theo topic này tới kết quả cuối cùng ạ.
Code chạy tốt với các yêu cầu thêm mà em yêu cầu rồi ạ.
Do Biên bản này em cần thêm nhiều thông tin khác theo mẫu sẵn : Nên nhờ anh chỉnh lại code kết quả tại sheet BienBan
Chỉ hiện thị kết quả từ cột A tới cột O ( cột N thể hiện số đôi, cột O thể hiện số thùng ).

View attachment 257182
Nhấp chuột vào đây để mở rộng...
Chỉnh code
Mã: 
Sub XYZ()
  Dim sArr(), Arr(), aSize(), tArr(), Res(), Dic As Object, iKey$
  Dim sRow&, sCol&, maxSize&
  Dim fR&, i&, j&, iR&, n&, k&
  Dim tmp, tDH$, soDH$, iCode$, TT#, TT2#
 
  Set Dic = CreateObject("scripting.dictionary")
  With Sheets("PKL")
    For j = 10 To 100
      If .Cells(7, j) = "PRS" Then sCol = j: Exit For
    Next j
    sArr = .Range("A7", .Cells(.Range("D" & Rows.Count).End(xlUp).Row, sCol)).Value
  End With
  sRow = UBound(sArr)
 
  ReDim aSize(1 To 1, 6 To 16) '11 Cot, tu cot F toi cot P
  ReDim tArr(1 To 4)
  ReDim Arr(1 To 100, 1 To 2)
  Arr = Array(Arr, Arr, tArr, aSize)
  For i = 2 To sRow
    tmp = sArr(i, 1)
    If InStr(1, tmp, ")/") > 0 Then
      soDH = Trim(Split(Split(tmp, "(")(1), ")")(0))
      iCode = Trim(Split(tmp, ":")(1))
      If Dic.exists(soDH) = False Then
        k = k + 1
        Dic.Add soDH, k
        ReDim Preserve Res(1 To k)
        Res(k) = Arr
        Res(k)(2)(3) = soDH '(3) So Don Hang
        For j = 6 To 16
          Res(k)(3)(1, j) = sArr(i - 1, j)
        Next j
      End If
    ElseIf tmp <> Empty And IsNumeric(tmp) Then
      n = Dic.Item(soDH)
      iKey = soDH & "|" & iCode & "|" & sArr(i, 4)
      If Dic.exists(iKey) = False Then
        iR = Res(n)(2)(4) + 1 '(4) So dong ket qua
        Res(n)(2)(4) = iR
        Dic.Add iKey, iR
        Res(n)(0)(iR, 1) = iCode: Res(n)(0)(iR, 2) = sArr(i, 4)
      End If
      iR = Dic.Item(iKey)
      Res(n)(1)(iR, 1) = Res(n)(1)(iR, 1) + sArr(i, sCol) 'so Doi
      Res(n)(1)(iR, 2) = Res(n)(1)(iR, 2) + sArr(i, sCol - 1) 'so Thung
      
      Res(n)(2)(1) = Res(n)(2)(1) + sArr(i, sCol) 'Tong so Doi
      Res(n)(2)(2) = Res(n)(2)(2) + sArr(i, sCol - 1) 'Tong so Thung
      TT = TT + sArr(i, sCol):    TT2 = TT2 + sArr(i, sCol - 1)
    End If
  Next i
 
  Application.ScreenUpdating = False
  fR = 1
  With Sheets("BienBan")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("A2:Z" & i).Clear
    For n = 1 To k
      sRow = Res(n)(2)(4)
      .Range("I1:J1").Copy .Range("I" & fR) 'Tieu de va So Don Hang"
      .Range("J" & fR) = Res(n)(2)(3) 'so Don Hang
      .Range("A" & fR + 1) = "STYLECODE"
      .Range("B" & fR + 1) = "COLOR"
      .Range("N" & fR + 1) = "ÐÔI"
      .Range("O" & fR + 1) = "THÙNG"
      .Range("C" & fR + 1).Resize(, 11) = Res(n)(3)
      .Range("A" & fR + 2).Resize(sRow, 2) = Res(n)(0)
      .Range("N" & fR + 2).Resize(sRow, 2) = Res(n)(1)
      .Range("A" & fR + sRow + 2) = "Total"
      .Range("N" & fR + sRow + 2) = Res(n)(2)(1)
      .Range("O" & fR + sRow + 2) = Res(n)(2)(2)
      .Range("A" & fR + sRow + 2).Resize(, 13).Merge
      .Range("A" & fR + sRow + 2).Resize(, 13).HorizontalAlignment = xlCenter
      .Range("A" & fR + 1).Resize(sRow + 2, 15).Borders.LineStyle = 1
      
      fR = fR + sRow + 3
    Next n
    .Range("A" & fR) = "Grand Total"
    .Range("N" & fR) = TT
    .Range("O" & fR) = TT2
    .Range("A" & fR).Resize(, 13).Merge
    .Range("A" & fR).Resize(, 13).HorizontalAlignment = xlCenter
    .Range("A" & fR).Resize(, 15).Borders.LineStyle = 1
  End With
  Application.ScreenUpdating = True
End Sub
 
HieuCD đã viết:
Chỉnh code
Mã: 
Sub XYZ()
  Dim sArr(), Arr(), aSize(), tArr(), Res(), Dic As Object, iKey$
  Dim sRow&, sCol&, maxSize&
  Dim fR&, i&, j&, iR&, n&, k&
  Dim tmp, tDH$, soDH$, iCode$, TT#, TT2#

  Set Dic = CreateObject("scripting.dictionary")
  With Sheets("PKL")
    For j = 10 To 100
      If .Cells(7, j) = "PRS" Then sCol = j: Exit For
    Next j
    sArr = .Range("A7", .Cells(.Range("D" & Rows.Count).End(xlUp).Row, sCol)).Value
  End With
  sRow = UBound(sArr)

  ReDim aSize(1 To 1, 6 To 16) '11 Cot, tu cot F toi cot P
  ReDim tArr(1 To 4)
  ReDim Arr(1 To 100, 1 To 2)
  Arr = Array(Arr, Arr, tArr, aSize)
  For i = 2 To sRow
    tmp = sArr(i, 1)
    If InStr(1, tmp, ")/") > 0 Then
      soDH = Trim(Split(Split(tmp, "(")(1), ")")(0))
      iCode = Trim(Split(tmp, ":")(1))
      If Dic.exists(soDH) = False Then
        k = k + 1
        Dic.Add soDH, k
        ReDim Preserve Res(1 To k)
        Res(k) = Arr
        Res(k)(2)(3) = soDH '(3) So Don Hang
        For j = 6 To 16
          Res(k)(3)(1, j) = sArr(i - 1, j)
        Next j
      End If
    ElseIf tmp <> Empty And IsNumeric(tmp) Then
      n = Dic.Item(soDH)
      iKey = soDH & "|" & iCode & "|" & sArr(i, 4)
      If Dic.exists(iKey) = False Then
        iR = Res(n)(2)(4) + 1 '(4) So dong ket qua
        Res(n)(2)(4) = iR
        Dic.Add iKey, iR
        Res(n)(0)(iR, 1) = iCode: Res(n)(0)(iR, 2) = sArr(i, 4)
      End If
      iR = Dic.Item(iKey)
      Res(n)(1)(iR, 1) = Res(n)(1)(iR, 1) + sArr(i, sCol) 'so Doi
      Res(n)(1)(iR, 2) = Res(n)(1)(iR, 2) + sArr(i, sCol - 1) 'so Thung
     
      Res(n)(2)(1) = Res(n)(2)(1) + sArr(i, sCol) 'Tong so Doi
      Res(n)(2)(2) = Res(n)(2)(2) + sArr(i, sCol - 1) 'Tong so Thung
      TT = TT + sArr(i, sCol):    TT2 = TT2 + sArr(i, sCol - 1)
    End If
  Next i

  Application.ScreenUpdating = False
  fR = 1
  With Sheets("BienBan")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 1 Then .Range("A2:Z" & i).Clear
    For n = 1 To k
      sRow = Res(n)(2)(4)
      .Range("I1:J1").Copy .Range("I" & fR) 'Tieu de va So Don Hang"
      .Range("J" & fR) = Res(n)(2)(3) 'so Don Hang
      .Range("A" & fR + 1) = "STYLECODE"
      .Range("B" & fR + 1) = "COLOR"
      .Range("N" & fR + 1) = "ÐÔI"
      .Range("O" & fR + 1) = "THÙNG"
      .Range("C" & fR + 1).Resize(, 11) = Res(n)(3)
      .Range("A" & fR + 2).Resize(sRow, 2) = Res(n)(0)
      .Range("N" & fR + 2).Resize(sRow, 2) = Res(n)(1)
      .Range("A" & fR + sRow + 2) = "Total"
      .Range("N" & fR + sRow + 2) = Res(n)(2)(1)
      .Range("O" & fR + sRow + 2) = Res(n)(2)(2)
      .Range("A" & fR + sRow + 2).Resize(, 13).Merge
      .Range("A" & fR + sRow + 2).Resize(, 13).HorizontalAlignment = xlCenter
      .Range("A" & fR + 1).Resize(sRow + 2, 15).Borders.LineStyle = 1
     
      fR = fR + sRow + 3
    Next n
    .Range("A" & fR) = "Grand Total"
    .Range("N" & fR) = TT
    .Range("O" & fR) = TT2
    .Range("A" & fR).Resize(, 13).Merge
    .Range("A" & fR).Resize(, 13).HorizontalAlignment = xlCenter
    .Range("A" & fR).Resize(, 15).Borders.LineStyle = 1
  End With
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Em cảm ơn anh nhiều ạ.
Kết quả đúng yêu cầu rồi ạ.
 
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

dangvandang
  • Question Question
Chia sẻ tích hợp trí tuệ nhân tạo (AI) vào excel
    • Thích
Trả lời
8
Đọc
2K
dangvandang
dangvandang
ankhanh2k2
sắp xếp dữ liệu chấm công
Trả lời
4
Đọc
61
DeTong
D
HeSanbi
  • Question Question
Công cụ tạo và chỉnh sửa Ribbon ngay trên Excel (Bản Việt hóa)
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
10
Đọc
6K
HeSanbi
HeSanbi
S
  • Question Question
Nhờ Mọi người giúp đỡ gộp nhiều dòng thành 1 dòng nhiều cột trong Power Query.
Trả lời
2
Đọc
68
SteveNguyen1991
S
PhanTuHuong
Hà Nội hẹn hò gặp gỡ đầu năm 2025 thôi :)
Trả lời
0
Đọc
34
PhanTuHuong
PhanTuHuong
N
  • Question Question
Xin code link dữ liệu VBA ạ !
Trả lời
1
Đọc
49
BuiQuangThuan
B
Đỗ Tú Anh
♪♫♪ ~ Thư Giãn Với Âm Nhạc ~ ♫♪♫
    • Thích
21 22 23
Trả lời
446
Đọc
11K
SA_DQ
SA_DQ
T
Bảng tính trợ cấp theo Nghị định 178 và tính lương hưu
    • Thích
Trả lời
7
Đọc
364
trung_bhxh
T
toanthinh
Công thức tính tuổi âm lịch
Trả lời
3
Đọc
79
toanthinh
toanthinh
S
Cần hỗ trợ xử lý hiện ngày sản phẩm bằng VBA
Trả lời
0
Đọc
45
sonminhtran
S
nghiahandsome1995
  • Question Question
in đậm chuỗi văn bản bằng excel
Trả lời
7
Đọc
149
HeSanbi
HeSanbi
GPE-Trợ Lý
[GPE] TALK SHOW EXCEL TRONG SẢN XUẤT
    • Thích
Trả lời
2
Đọc
721
GPE-Trợ Lý
GPE-Trợ Lý
Nguyễn Duy Tuân
Phiên bản mới Add-in A-Tools v10 (2024)
    • Thích
2 3
Trả lời
40
Đọc
3K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
T
  • Question Question
Mong mọi người giúp đỡ em trường hợp này với ạ.
Trả lời
1
Đọc
106
thanhduybg92
T
T
Bảng tính trợ cấp theo Nghị định 178 và tính lương hưu
    • Thích
Trả lời
1
Đọc
56
vn72259
V
giaiphap
Add-Ins cho Excel 2007 -2016 32bit và 64bit
    • Thích
    • Yêu thích
    • Ngạc nhiên
24 25 26
Trả lời
512
Đọc
192K
vn72259
V
HeSanbi
  • Đã giải quyết
ZaloExcel v2.94: Gửi tin nhắn, hình ảnh, bảng, biểu đồ, tập tin, tạo nhóm, thu thập tin nhắn
    • Thích
    • Cảm ơn
    • Yêu thích
2 3
Trả lời
56
Đọc
15K
HeSanbi
HeSanbi
quyenpv
Hỗ trợ công thức dò tìn Index, Match trong bảng dò tìm kết quả
Trả lời
5
Đọc
103
quyenpv
quyenpv
B
Suy nghĩ của tui
    • Thích
2 3 4
Trả lời
60
Đọc
7K
SA_DQ
SA_DQ
H
In các trang theo điều kiện
Trả lời
3
Đọc
61
HUONGHCKT
H
Xem thêm…

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

000
Ngày
00
Giờ
00
phút
00
giây
TALK SHOW EXCEL TRONG SẢN XUẤT
Back
Top Bottom