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

  • 210414_CHUYEN doi dinh dang filevd khac 2.xlsm
    275.6 KB · Đọc: 6
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

phanmoi688
[Xin nhờ giúp đỡ] Cách đối chiếu dữ liệu giữa hai biểu
    • Thích
Trả lời
11
Đọc
107
phanmoi688
phanmoi688
Maika8008
Tặng file quản lý vật tư - công nợ (nhập xuất kho hàng và công nợ khách hàng)
    • Thích
    • Yêu thích
    • Cảm ơn
4 5 6
Trả lời
108
Đọc
19K
BuiQuangThuan
B
V
  • Question
Tìm kiếm và copy giá trị từ bảng đến bảng khác
Trả lời
3
Đọc
40
BuiQuangThuan
B
O
Nhờ sửa code tự động trừ đi một giá trị trong vùng được chọn
Trả lời
5
Đọc
72
ohlexus
O
H
  • Question
Em nhờ các bác làm giúp em in và lưu lịch sử lệnh sản xuất
Trả lời
7
Đọc
204
hiv174
H
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

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

Back
Top Bottom