Nhờ rút gọn bảng tính sang phiếu in

Liên hệ QC
M

moihocvba

Thành viên thường trực
Tham gia
16/8/20
Bài viết
211
Được thích
50
Em chào anh chị GPE, chúc anh chị đầu năm mới sức khỏe và nhiều niềm vui ạ!
Sau khi học hỏi cách rút gọn bảng tính của anh chị ở bài này: https://www.giaiphapexcel.com/diend...h-và-thêm-dòng-tổng-cộng.158905/#post-1057014

Thì em đã áp dụng được vào file của em, nhưng có vấn đề là chỉ gộp và thêm dòng tổng cộng cho những tên hàng nào có 2 dòng liên tiếp trở lên, nếu có 1 dòng thì vẫn như cũ.

Đây là bảng gốc:

1644374360208.png

Đây là kết quả sau khi áp dụng bài trước cho ra:
1644374963808.png

Nhưng có những sản phẩm chỉ xuất hiện 1 lần nên e không thêm dòng tổng cộng và vẫn hiện như sheet nhập liệu, em muốn như thế này:

1644374698483.png

Đây là code của em đã viết ạ, anh chị giúp em chỉnh code để được bảng trên ạ. Em cám ơn nhiều!
Mã: 
Sub LayDuLieuSangTrangIn()
    Dim sArr(), dArr(1 To 10000, 1 To 10), i%, j%, Total(4 To 9) As Double, k%, aRow%, lr As Long
    lr = ShList.Range("C222").End(xlUp).Row
    sArr = Sheets("ShList").Range("B21:J" & lr).Value
    k = 0: aRow = UBound(sArr)
    For i = 1 To aRow
        k = k + 1
        If i <> 1 Then
            If (sArr(i, 2) <> sArr(i - 1, 2)) Then
                For j = 4 To 9
                    dArr(k, j) = Total(j)
                    Total(j) = 0
                Next j
                k = k + 1
                dArr(k, 1) = sArr(i, 1)
                dArr(k, 2) = sArr(i, 2)
                dArr(k, 3) = sArr(i, 3)
                dArr(k, 4) = sArr(i, 4)
                dArr(k, 5) = sArr(i, 5)
                dArr(k, 6) = sArr(i, 6)
                dArr(k, 7) = sArr(i, 7)
                Total(8) = sArr(i, 8)
                Total(4) = Total(4) + sArr(i, 4)
                Total(7) = Total(7) + sArr(i, 7)
                Total(9) = Total(9) + sArr(i, 9)
            Else
                dArr(k, 1) = sArr(i, 1)
                dArr(k, 3) = sArr(i, 3)
                dArr(k, 4) = sArr(i, 4)
                dArr(k, 5) = sArr(i, 5)
                dArr(k, 6) = sArr(i, 6)
                dArr(k, 7) = sArr(i, 7)
                Total(8) = sArr(i, 8)
                Total(4) = Total(4) + sArr(i, 4)
                Total(7) = Total(7) + sArr(i, 7)
                Total(9) = Total(9) + sArr(i, 9)
            End If
        Else
                dArr(k, 1) = sArr(i, 1)
                dArr(k, 2) = sArr(i, 2)
                dArr(k, 3) = sArr(i, 3)
                dArr(k, 4) = sArr(i, 4)
                dArr(k, 5) = sArr(i, 5)
                dArr(k, 6) = sArr(i, 6)
                dArr(k, 7) = sArr(i, 7)
                Total(8) = sArr(i, 8)
                Total(4) = Total(4) + sArr(i, 4)
                Total(7) = Total(7) + sArr(i, 7)
                 Total(9) = Total(9) + sArr(i, 9)
        End If
    Next i
    Sheets("Phieuin").Range("B21:S220").ClearContents
    If k Then
        k = k + 1
        For j = 4 To 9
            dArr(k, j) = Total(j)
        Next j
        If k < 200 Then
            Sheets("Phieuin").Range("B21").Resize(k, 10).Value = dArr
        Else
            MsgBox "Du lieu qua lon vuot qua 200 dong! Khong the in phieu!"
        End If
    End If
End Sub

Những sản phẩm giống nhau em sẽ để gần nhau ạ!
 

File đính kèm

  • GPE.xlsm
    49.3 KB · Đọc: 27
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Với điều kiện "Những sản phẩm giống nhau em sẽ để gần nhau ạ!".
Mã: 
Sub LayDuLieuSangTrangIn()
  Dim sArr(), res(), aTong() As Double, hang$
  Dim i&, j&, k&, sRow&, sCol&, eRow&
  eRow = ShList.Range("C" & Rows.Count).End(xlUp).Row
  sArr = Sheets("ShList").Range("A21:J" & eRow + 1).Value
  sRow = UBound(sArr) - 1: sCol = UBound(sArr, 2)
  ReDim res(1 To sRow * 2, 1 To sCol)
  ReDim aTong(4 To 10)
  For i = 1 To sRow
    k = k + 1
    For j = 1 To sCol
      res(k, j) = sArr(i, j)
    Next j
    aTong(5) = aTong(5) + sArr(i, 5)
    aTong(8) = aTong(8) + sArr(i, 8)
    aTong(10) = aTong(10) + sArr(i, 10)
    aTong(4) = aTong(4) + 1
    aTong(9) = sArr(i, 9)
    If sArr(i, 3) <> sArr(i + 1, 3) Then
      If aTong(4) > 1 Then
        k = k + 1
        For j = 5 To 10
          res(k, j) = aTong(j)
        Next j
      End If
      ReDim aTong(4 To 10)
    End If
  Next i
  Sheets("Phieuin").Range("A21:S220").ClearContents
  If k Then
    If k < 200 Then
      Sheets("Phieuin").Range("A21").Resize(k, 10).Value = res
    Else
      MsgBox "Du lieu qua lon vuot qua 200 dong! Khong the in phieu!"
    End If
  End If
End Sub
 
Upvote 0
HieuCD đã viết:
Với điều kiện "Những sản phẩm giống nhau em sẽ để gần nhau ạ!".
Mã: 
Sub LayDuLieuSangTrangIn()
  Dim sArr(), res(), aTong() As Double, hang$
  Dim i&, j&, k&, sRow&, sCol&, eRow&
  eRow = ShList.Range("C" & Rows.Count).End(xlUp).Row
  sArr = Sheets("ShList").Range("A21:J" & eRow + 1).Value
  sRow = UBound(sArr) - 1: sCol = UBound(sArr, 2)
  ReDim res(1 To sRow * 2, 1 To sCol)
  ReDim aTong(4 To 10)
  For i = 1 To sRow
    k = k + 1
    For j = 1 To sCol
      res(k, j) = sArr(i, j)
    Next j
    aTong(5) = aTong(5) + sArr(i, 5)
    aTong(8) = aTong(8) + sArr(i, 8)
    aTong(10) = aTong(10) + sArr(i, 10)
    aTong(4) = aTong(4) + 1
    aTong(9) = sArr(i, 9)
    If sArr(i, 3) <> sArr(i + 1, 3) Then
      If aTong(4) > 1 Then
        k = k + 1
        For j = 5 To 10
          res(k, j) = aTong(j)
        Next j
      End If
      ReDim aTong(4 To 10)
    End If
  Next i
  Sheets("Phieuin").Range("A21:S220").ClearContents
  If k Then
    If k < 200 Then
      Sheets("Phieuin").Range("A21").Resize(k, 10).Value = res
    Else
      MsgBox "Du lieu qua lon vuot qua 200 dong! Khong the in phieu!"
    End If
  End If
End Sub
Nhấp chuột vào đây để mở rộng...
Em cảm ơn anh rất nhiều ạ!
Anh giúp em 1 chỗ nữa là hoàn thiện. Phần đơn giá và thành tiền của những mã hàng lặp lại mình bỏ để khỏi nhìn rối, chỉ hiện 1 lần ở dòng tổng thôi (vì đơn giá bằng nhau cả) ạ!
1644392724318.png
 
Upvote 0
moihocvba đã viết:
Em cảm ơn anh rất nhiều ạ!
Anh giúp em 1 chỗ nữa là hoàn thiện. Phần đơn giá và thành tiền của những mã hàng lặp lại mình bỏ để khỏi nhìn rối, chỉ hiện 1 lần ở dòng tổng thôi (vì đơn giá bằng nhau cả) ạ!
View attachment 272006
Nhấp chuột vào đây để mở rộng...
Sửa điều kiện ở code #2
Mã: 
Sub LayDuLieuSangTrangIn()
  Dim sArr(), res(), aTong() As Double, hang$
  Dim i&, j&, k&, sRow&, sCol&, eRow&
  eRow = ShList.Range("C" & Rows.Count).End(xlUp).Row
  sArr = Sheets("ShList").Range("A21:J" & eRow + 1).Value
  sRow = UBound(sArr) - 1: sCol = UBound(sArr, 2)
  ReDim res(1 To sRow * 2, 1 To sCol)
  ReDim aTong(4 To 10)
  For i = 1 To sRow
    k = k + 1
    For j = 1 To sCol
      res(k, j) = sArr(i, j)
    Next j
    aTong(5) = aTong(5) + sArr(i, 5)
    aTong(8) = aTong(8) + sArr(i, 8)
    aTong(10) = aTong(10) + sArr(i, 10)
    aTong(4) = aTong(4) + 1
    aTong(9) = sArr(i, 9)
    If sArr(i, 3) <> sArr(i + 1, 3) Then
      If aTong(4) > 1 Then
        k = k + 1
        For j = 5 To 10
          res(k, j) = aTong(j)
        Next j
        res(k - 1, 9) = Empty: res(k - 1, 10) = Empty
      End If
      ReDim aTong(4 To 10)
    Else
        res(k, 9) = Empty: res(k, 10) = Empty
    End If
  Next i
  Sheets("Phieuin").Range("A21:S220").ClearContents
  If k Then
    If k < 200 Then
      Sheets("Phieuin").Range("A21").Resize(k, 10).Value = res
    Else
      MsgBox "Du lieu qua lon vuot qua 200 dong! Khong the in phieu!"
    End If
  End If
End Sub
 
Upvote 0
moihocvba đã viết:
Em cảm ơn anh rất nhiều ạ!
Anh giúp em 1 chỗ nữa là hoàn thiện. Phần đơn giá và thành tiền của những mã hàng lặp lại mình bỏ để khỏi nhìn rối, chỉ hiện 1 lần ở dòng tổng thôi (vì đơn giá bằng nhau cả) ạ!
View attachment 272006
Nhấp chuột vào đây để mở rộng...
Chỉnh lại các lệnh tí xíu
Mã: 
Sub LayDuLieuSangTrangIn()
  Dim sArr(), res(), aTong()
  Dim i&, j&, k&, sRow&, sCol&, eRow&
  eRow = ShList.Range("C" & Rows.Count).End(xlUp).Row
  sArr = Sheets("ShList").Range("A21:J" & eRow + 1).Value
  sRow = UBound(sArr) - 1: sCol = UBound(sArr, 2)
  ReDim res(1 To sRow * 2, 1 To sCol)
  ReDim aTong(4 To 10)
  For i = 1 To sRow
    k = k + 1
    For j = 1 To 8
      res(k, j) = sArr(i, j)
    Next j
    aTong(5) = aTong(5) + sArr(i, 5)
    aTong(8) = aTong(8) + sArr(i, 8)
    aTong(10) = aTong(10) + sArr(i, 10)
    aTong(4) = aTong(4) + 1
    aTong(9) = sArr(i, 9)
    If sArr(i, 3) <> sArr(i + 1, 3) Then
      If aTong(4) > 1 Then
        k = k + 1
        For j = 5 To 10
          res(k, j) = aTong(j)
        Next j
      Else
        res(k, 9) = sArr(i, 9)
        res(k, 10) = sArr(i, 10)
      End If
      ReDim aTong(4 To 10)
    End If
  Next i
  Sheets("Phieuin").Range("A21:S220").ClearContents
  If k Then
    If k <= 200 Then
      Sheets("Phieuin").Range("A21").Resize(k, 10).Value = res
    Else
      MsgBox "Du lieu qua lon vuot qua 200 dong! Khong the in phieu!"
    End If
  End If
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
HieuCD đã viết:
Chỉnh lại các lệnh tí xíu
Mã: 
Sub LayDuLieuSangTrangIn()
  Dim sArr(), res(), aTong()
  Dim i&, j&, k&, sRow&, sCol&, eRow&
  eRow = ShList.Range("C" & Rows.Count).End(xlUp).Row
  sArr = Sheets("ShList").Range("A21:J" & eRow + 1).Value
  sRow = UBound(sArr) - 1: sCol = UBound(sArr, 2)
  ReDim res(1 To sRow * 2, 1 To sCol)
  ReDim aTong(4 To 10)
  For i = 1 To sRow
    k = k + 1
    For j = 1 To 8
      res(k, j) = sArr(i, j)
    Next j
    aTong(5) = aTong(5) + sArr(i, 5)
    aTong(8) = aTong(8) + sArr(i, 8)
    aTong(10) = aTong(10) + sArr(i, 10)
    aTong(4) = aTong(4) + 1
    aTong(9) = sArr(i, 9)
    If sArr(i, 3) <> sArr(i + 1, 3) Then
      If aTong(4) > 1 Then
        k = k + 1
        For j = 5 To 10
          res(k, j) = aTong(j)
        Next j
      Else
        res(k, 9) = sArr(i, 9)
        res(k, 10) = sArr(i, 10)
      End If
      ReDim aTong(4 To 10)
    End If
  Next i
  Sheets("Phieuin").Range("A21:S220").ClearContents
  If k Then
    If k <= 200 Then
      Sheets("Phieuin").Range("A21").Resize(k, 10).Value = res
    Else
      MsgBox "Du lieu qua lon vuot qua 200 dong! Khong the in phieu!"
    End If
  End If
End Sub
Nhấp chuột vào đây để mở rộng...
Em muốn sau mỗi dòng cộng của phiếu in được in đậm và thêm một dòng tổng cộng của số lượng và thành tiền phải làm như nào nữa anh. Em xin cám ơn rất nhiều
 
Upvote 0
queluatb đã viết:
Em muốn sau mỗi dòng cộng của phiếu in được in đậm và thêm một dòng tổng cộng của số lượng và thành tiền phải làm như nào nữa anh. Em xin cám ơn rất nhiều
Nhấp chuột vào đây để mở rộng...
Số lượng của sản phẩm khác nhau không cộng với nhau
Mã: 
Option Explicit
Sub LayDuLieuSangTrangIn()
  Dim sArr(), res(), aTong()
  Dim i&, j&, k&, sRow&, sCol&, eRow&, total#
  eRow = ShList.Range("C" & Rows.Count).End(xlUp).Row
  sArr = Sheets("ShList").Range("A21:J" & eRow + 1).Value
  sRow = UBound(sArr) - 1: sCol = UBound(sArr, 2)
  ReDim res(1 To sRow * 2, 1 To sCol)
  ReDim aTong(4 To 10)
  For i = 1 To sRow
    k = k + 1
    For j = 1 To 8
      res(k, j) = sArr(i, j)
    Next j
    aTong(5) = aTong(5) + sArr(i, 5)
    aTong(8) = aTong(8) + sArr(i, 8)
    aTong(10) = aTong(10) + sArr(i, 10)
    aTong(4) = aTong(4) + 1
    aTong(9) = sArr(i, 9)
    If sArr(i, 3) <> sArr(i + 1, 3) Then
      If aTong(4) > 1 Then
        k = k + 1
        For j = 5 To 10
          res(k, j) = aTong(j)
        Next j
      Else
        res(k, 9) = sArr(i, 9)
        res(k, 10) = sArr(i, 10)
      End If
      total = total + aTong(10)
      ReDim aTong(4 To 10)
    End If
  Next i
  With Sheets("Phieuin")
    .Range("A21:K220").Clear
    If k Then
      If k <= 200 Then
        .Range("A21").Resize(k, 10).Value = res
        .Range("A21").Resize(k + 1, 11).Borders.LineStyle = 1
        .Range("A21").Resize(k + 1, 11).Font.Size = 13
        .Range("e21").Resize(k + 1, 6).NumberFormat = "#,### "
        For i = 21 To 21 + k
          If .Range("C" & i).Value = Empty Then .Range("C" & i).Resize(, 9).Font.Bold = True
        Next i
        .Range("C" & i - 1).Value = "Total"
        .Range("J" & i - 1).Value = total
      Else
        MsgBox "Du lieu qua lon vuot qua 200 dong! Khong the in phieu!"
      End If
    End If
  End With
End Sub
 
Upvote 0
HieuCD đã viết:
Số lượng của sản phẩm khác nhau không cộng với nhau
Mã: 
Option Explicit
Sub LayDuLieuSangTrangIn()
  Dim sArr(), res(), aTong()
  Dim i&, j&, k&, sRow&, sCol&, eRow&, total#
  eRow = ShList.Range("C" & Rows.Count).End(xlUp).Row
  sArr = Sheets("ShList").Range("A21:J" & eRow + 1).Value
  sRow = UBound(sArr) - 1: sCol = UBound(sArr, 2)
  ReDim res(1 To sRow * 2, 1 To sCol)
  ReDim aTong(4 To 10)
  For i = 1 To sRow
    k = k + 1
    For j = 1 To 8
      res(k, j) = sArr(i, j)
    Next j
    aTong(5) = aTong(5) + sArr(i, 5)
    aTong(8) = aTong(8) + sArr(i, 8)
    aTong(10) = aTong(10) + sArr(i, 10)
    aTong(4) = aTong(4) + 1
    aTong(9) = sArr(i, 9)
    If sArr(i, 3) <> sArr(i + 1, 3) Then
      If aTong(4) > 1 Then
        k = k + 1
        For j = 5 To 10
          res(k, j) = aTong(j)
        Next j
      Else
        res(k, 9) = sArr(i, 9)
        res(k, 10) = sArr(i, 10)
      End If
      total = total + aTong(10)
      ReDim aTong(4 To 10)
    End If
  Next i
  With Sheets("Phieuin")
    .Range("A21:K220").Clear
    If k Then
      If k <= 200 Then
        .Range("A21").Resize(k, 10).Value = res
        .Range("A21").Resize(k + 1, 11).Borders.LineStyle = 1
        .Range("A21").Resize(k + 1, 11).Font.Size = 13
        .Range("e21").Resize(k + 1, 6).NumberFormat = "#,### "
        For i = 21 To 21 + k
          If .Range("C" & i).Value = Empty Then .Range("C" & i).Resize(, 9).Font.Bold = True
        Next i
        .Range("C" & i - 1).Value = "Total"
        .Range("J" & i - 1).Value = total
      Else
        MsgBox "Du lieu qua lon vuot qua 200 dong! Khong the in phieu!"
      End If
    End If
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
em xin cám ơn rất nhiều
 
Upvote 0
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

thlpro
Truy Vấn Công thức từ Sheet này Qua Sheet Khác
Trả lời
4
Đọc
76
Hoàng Tuấn 868
H
GPE-Trợ Lý
Đăng ký tham dự hội thảo tại Hà Nội: Power Query - Công cụ quản lý dữ liệu
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
5
Đọc
605
GPE-Trợ Lý
GPE-Trợ Lý
N
  • Question
Làm ơn viết giùm mình macro làm tròn giá trị ạ
    • Cười
Trả lời
14
Đọc
85
ptm0412
ptm0412
S
Lý do công thức bị mờ tại ô Function
    • Cười
Trả lời
1
Đọc
16
ptm0412
ptm0412
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
8 9 10
Trả lời
191
Đọc
10K
ongke0711
ongke0711
CNKyNguyen
Giảm dung lượng của file excel
    • Cảm ơn
    • Cười
    • Thích
Trả lời
2
Đọc
221
CNKyNguyen
CNKyNguyen
hunganh.nguyen
Xin giúp code tách dòng tổng thành những dòng chi tiết với giá trị là 1
Trả lời
9
Đọc
401
vostro 1500
vostro 1500
T
Xin trợ giúp code về dò tìm dữ liệu
Trả lời
0
Đọc
47
THU UYEN317
T
P
Sự cố về hàm SUMIF
Trả lời
8
Đọc
226
yeudoi
yeudoi
OverAC
Thông báo nội dung xấu và bài viết vi phạm nội quy.
19 20 21
Trả lời
416
Đọc
41K
vanle33
vanle33
S
Chuyển định dạng thời gian từ sa/ch sang AM/PM
Trả lời
2
Đọc
65
Silklynk
S
B
Sắp xếp lịch trực
5 6 7
Trả lời
130
Đọc
86K
TTVAN28
TTVAN28
N
Giúp em hàm Aggregate không chạy được trên Google sheet ah
Trả lời
4
Đọc
133
nguyenthieny
N
N
  • Question
VBA - copy các sheets unhide và dạng giá trị theo vùng xác định
Trả lời
2
Đọc
77
bebo021999
B
hoaithanh9480
Nhờ giúp đỡ về kiểm phiếu bầu
Trả lời
4
Đọc
98
hoaithanh9480
hoaithanh9480
B
Nhờ anh/chị giúp em tìm hàm cho công thức tính lương
Trả lời
2
Đọc
131
hoangtuaotrang_hp_vn
H
SA_DQ
Phẩu thuật Nụ cười lần 3 tại Huế.
    • Thích
    • Yêu thích
Trả lời
1
Đọc
92
HUONGHCKT
H
K
  • Question
Sử dụng Power Query để xử lý nhật ký chung nhiều nợ nhiều có
    • Cười
Trả lời
14
Đọc
289
viethung78
V
N
cộng các dữ liệu không trùng nhau
Trả lời
13
Đọc
235
DeTong
D
T
Lỗi import dữ liệu
Trả lời
1
Đọc
51
ongke0711
ongke0711
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

Back
Top Bottom