Em nhờ viết code VBA chuyển đổi giữa 2 bảng

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 ạ, em nhờ anh chị viết code VBA chuyển giúp em từ Bảng 1 thành Bảng 2 ạ.
Bảng của em chỉ có 2 sản phẩm, khi viết hóa đơn tính tiền thì viết ở bảng 1, nhưng khi in số lượng gửi cho khách thì in bảng 2 để cho khách dễ nhìn.
Thường nhập hết 1 tuần thì em mới in cho khách 1 lần ở Bảng 2.
Bảng 2 không quan tâm đến giá. Chỉ quan tâm tới cột SL, cũng không cần ĐVT hoặc Thành tiền
Em cám ơn anh chị đã giúp đỡ em ạ!

1659086332319.png
 

File đính kèm

  • Hoa don.xlsx
    11.9 KB · Đọc: 10
Sắp xếp theo thời gian sắp xếp theo bầu chọn
moihocvba đã viết:
Em chào anh chị GPE ạ, em nhờ anh chị viết code VBA chuyển giúp em từ Bảng 1 thành Bảng 2 ạ.
Bảng của em chỉ có 2 sản phẩm, khi viết hóa đơn tính tiền thì viết ở bảng 1, nhưng khi in số lượng gửi cho khách thì in bảng 2 để cho khách dễ nhìn.
Thường nhập hết 1 tuần thì em mới in cho khách 1 lần ở Bảng 2.
Bảng 2 không quan tâm đến giá. Chỉ quan tâm tới cột SL, cũng không cần ĐVT hoặc Thành tiền
Em cám ơn anh chị đã giúp đỡ em ạ!
Nhấp chuột vào đây để mở rộng...
Xin lỗi. Đã cập nhật thông tin.......... .... .... ..... .....
Kết quả chỉ cần điền vô cột M và N thôi hả
 
Upvote 0
Pivot xong copy qua bảng kia. Chẳng thấy gì bất tiện cả.
 
Upvote 0
Code pivot kiểu này xem sao ?
 

File đính kèm

  • Hoa don22.xlsm
    20 KB · Đọc: 9
Upvote 0
moihocvba đã viết:
Em chào anh chị GPE ạ, em nhờ anh chị viết code VBA chuyển giúp em từ Bảng 1 thành Bảng 2 ạ.
Bảng của em chỉ có 2 sản phẩm, khi viết hóa đơn tính tiền thì viết ở bảng 1, nhưng khi in số lượng gửi cho khách thì in bảng 2 để cho khách dễ nhìn.
Thường nhập hết 1 tuần thì em mới in cho khách 1 lần ở Bảng 2.
Bảng 2 không quan tâm đến giá. Chỉ quan tâm tới cột SL, cũng không cần ĐVT hoặc Thành tiền
Em cám ơn anh chị đã giúp đỡ em ạ!

View attachment 279391
Nhấp chuột vào đây để mở rộng...
Bạn thử Code dưới xem sao!:victory:
Mã: 
Option Explicit
Sub ABC()
    Dim Lr&, i&, ii&, j&, k&, m&, Lr1&, Lc1&
    Dim Arr(), Arr1(), Res(), Dic As Object, Rng2 As Range
    Dim Key$, Key1$, Res1(), Res2(), Rng As Range, Rng1 As Range
    Set Dic = CreateObject("Scripting.Dictionary")
    With Sheet1
        .Range("P1:AP10000").ClearContents
        Lr = .Range("B" & Rows.Count).End(xlUp).Row
        Set Rng = .Range("B3:B" & Lr)
        Set Rng1 = .Range("C3:C" & Lr)
        Set Rng2 = .Range("E3:E" & Lr)
        Arr = .Range("B3:E" & Lr).Value
        ReDim Res(1 To UBound(Arr), 1 To 2)
        ReDim Res1(1 To UBound(Arr), 1 To 1)
        ReDim Res2(1 To 1000, 1 To 1000)
        For i = 1 To UBound(Arr)
            If Arr(i, 1) <> "" And Arr(i, 2) <> "" Then
                Key = "A" & Arr(i, 1)
                If Not Dic.exists(Key) Then
                    k = k + 1: Dic.Add (Key), k
                    Res(k, 1) = k
                    Res(k, 2) = Arr(i, 1)
                End If
                Key1 = "A" & Arr(i, 2)
                If Not Dic.exists(Key1) Then
                    m = m + 1: Dic.Add (Key1), m
                    Res1(m, 1) = Arr(i, 2)
                End If
            End If
        Next i
        .Range("P3").Resize(k, 2).Value = Res
        .Range("R2").Resize(1, m).Value = Application.Transpose(Res1)
        Lr1 = .Range("Q" & Rows.Count).End(xlUp).Row
        Lc1 = .Cells(2, Columns.Count).End(xlToLeft).Column
        Arr1 = .Range(Cells(2, 17), Cells(Lr1, Lc1)).Value
        For ii = 2 To k + 1
            For j = 2 To m + 1
                Res2(ii - 1, j - 1) = Application.SumIfs(Rng2, Rng, Arr1(ii, 1), Rng1, Arr1(1, j))
            Next j
        Next ii
        .Range("R3").Resize(k, m).Value = Res2
    End With
    Set Dic = Nothing
    Set Rng = Nothing
    Set Rng1 = Nothing
    Set Rng2 = Nothing
End Sub
 

File đính kèm

  • Hoa don.xlsb
    21.5 KB · Đọc: 12
Upvote 0
THÓC SAMA đã viết:
Bạn thử Code dưới xem sao!:victory:
Mã: 
Option Explicit
Sub ABC()
    Dim Lr&, i&, ii&, j&, k&, m&, Lr1&, Lc1&
    Dim Arr(), Arr1(), Res(), Dic As Object, Rng2 As Range
    Dim Key$, Key1$, Res1(), Res2(), Rng As Range, Rng1 As Range
    Set Dic = CreateObject("Scripting.Dictionary")
    With Sheet1
        .Range("P1:AP10000").ClearContents
        Lr = .Range("B" & Rows.Count).End(xlUp).Row
        Set Rng = .Range("B3:B" & Lr)
        Set Rng1 = .Range("C3:C" & Lr)
        Set Rng2 = .Range("E3:E" & Lr)
        Arr = .Range("B3:E" & Lr).Value
        ReDim Res(1 To UBound(Arr), 1 To 2)
        ReDim Res1(1 To UBound(Arr), 1 To 1)
        ReDim Res2(1 To 1000, 1 To 1000)
        For i = 1 To UBound(Arr)
            If Arr(i, 1) <> "" And Arr(i, 2) <> "" Then
                Key = "A" & Arr(i, 1)
                If Not Dic.exists(Key) Then
                    k = k + 1: Dic.Add (Key), k
                    Res(k, 1) = k
                    Res(k, 2) = Arr(i, 1)
                End If
                Key1 = "A" & Arr(i, 2)
                If Not Dic.exists(Key1) Then
                    m = m + 1: Dic.Add (Key1), m
                    Res1(m, 1) = Arr(i, 2)
                End If
            End If
        Next i
        .Range("P3").Resize(k, 2).Value = Res
        .Range("R2").Resize(1, m).Value = Application.Transpose(Res1)
        Lr1 = .Range("Q" & Rows.Count).End(xlUp).Row
        Lc1 = .Cells(2, Columns.Count).End(xlToLeft).Column
        Arr1 = .Range(Cells(2, 17), Cells(Lr1, Lc1)).Value
        For ii = 2 To k + 1
            For j = 2 To m + 1
                Res2(ii - 1, j - 1) = Application.SumIfs(Rng2, Rng, Arr1(ii, 1), Rng1, Arr1(1, j))
            Next j
        Next ii
        .Range("R3").Resize(k, m).Value = Res2
    End With
    Set Dic = Nothing
    Set Rng = Nothing
    Set Rng1 = Nothing
    Set Rng2 = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Code chạy đúng rồi, rất cám ơn bạn.
Bạn cho mình hỏi chỗ này với:
Mã: 
Key = "A" & Arr(i, 1)

Tại sao lại nối với chữ A làm gì vậy ạ?
 
Upvote 0
Upvote 0
moihocvba đã viết:
Em chào anh chị GPE ạ, em nhờ anh chị viết code VBA chuyển giúp em từ Bảng 1 thành Bảng 2 ạ.
Bảng của em chỉ có 2 sản phẩm, khi viết hóa đơn tính tiền thì viết ở bảng 1, nhưng khi in số lượng gửi cho khách thì in bảng 2 để cho khách dễ nhìn.
Thường nhập hết 1 tuần thì em mới in cho khách 1 lần ở Bảng 2.
Bảng 2 không quan tâm đến giá. Chỉ quan tâm tới cột SL, cũng không cần ĐVT hoặc Thành tiền
Em cám ơn anh chị đã giúp đỡ em ạ!

View attachment 279391
Nhấp chuột vào đây để mở rộng...
Code này dùng cho file ở #1.
Mã: 
Sub GPE()
    Dim aRow&, i&, k&, j&
    Dim Sou(), Des(), Dic As Object
    With Sheet1
        aRow = .Range("K100000").End(xlUp).Row
        If aRow > 2 Then .Range("K3:N" & aRow).Clear
        aRow = .Range("I100000").End(xlUp).Row
        If aRow < 3 Then Exit Sub
        Sou = .Range("B3:E" & aRow).Value2
        ReDim Des(1 To UBound(Sou), 1 To 4)
        k = 0
        Set Dic = CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(Sou)
            If Sou(i, 1) <> "" Then
                If Sou(i, 2) = .Range("M2").Value2 Then
                    j = 3
                ElseIf Sou(i, 2) = .Range("N2").Value2 Then
                    j = 4
                Else
                    j = 0
                End If
                If Not Dic.exists(Sou(i, 1)) Then
                    If j Then
                        k = k + 1: Dic.Add (Sou(i, 1)), k
                        Des(k, 1) = k: Des(k, 2) = Sou(i, 1)
                        Des(k, j) = Sou(i, 4)
                    End If
                Else
                    If j Then Des(Dic.Item(Sou(i, 1)), j) = Des(Dic.Item(Sou(i, 1)), j) + Sou(i, 4)
                End If
            End If
        Next i
        If k Then
            .Range("K3").Resize(k, 4).Value = Des
            .Range("K3").Resize(k, 4).Borders.LineStyle = 1
            .Range("L3").Resize(k).NumberFormat = "m/d/yyyy"
        End If
        Set Dic = Nothing
    End With
End Sub
 
Upvote 0
giaiphap đã viết:
Code này dùng cho file ở #1.
Mã: 
Sub GPE()
    Dim aRow&, i&, k&, j&
    Dim Sou(), Des(), Dic As Object
    With Sheet1
        aRow = .Range("K100000").End(xlUp).Row
        If aRow > 2 Then .Range("K3:N" & aRow).Clear
        aRow = .Range("I100000").End(xlUp).Row
        If aRow < 3 Then Exit Sub
        Sou = .Range("B3:E" & aRow).Value2
        ReDim Des(1 To UBound(Sou), 1 To 4)
        k = 0
        Set Dic = CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(Sou)
            If Sou(i, 1) <> "" Then
                If Sou(i, 2) = .Range("M2").Value2 Then
                    j = 3
                ElseIf Sou(i, 2) = .Range("N2").Value2 Then
                    j = 4
                Else
                    j = 0
                End If
                If Not Dic.exists(Sou(i, 1)) Then
                    If j Then
                        k = k + 1: Dic.Add (Sou(i, 1)), k
                        Des(k, 1) = k: Des(k, 2) = Sou(i, 1)
                        Des(k, j) = Sou(i, 4)
                    End If
                Else
                    If j Then Des(Dic.Item(Sou(i, 1)), j) = Des(Dic.Item(Sou(i, 1)), j) + Sou(i, 4)
                End If
            End If
        Next i
        If k Then
            .Range("K3").Resize(k, 4).Value = Des
            .Range("K3").Resize(k, 4).Borders.LineStyle = 1
            .Range("L3").Resize(k).NumberFormat = "m/d/yyyy"
        End If
        Set Dic = Nothing
    End With
End Sub
Nhấp chuột vào đây để mở rộng...
Nhờ anh @giaiphap sửa code tương tự bị thiếu mất 1 dòng và sắp xếp tên sản phẩm theo thứ tự tăng dần giúp em với !
Mã: 
Public Sub GPE()
Dim Dic As Object, sArr(), dArr(), Txt As String
Dim i As Long, K As Long, R As Long, Rws As Long, col As Long, xRow As Long, xCol As Long
With Sheets("Sheet1")
    Rws = .Range("B10000").End(xlUp).Row
    If Rws < 3 Then Exit Sub
    Set Dic = CreateObject("Scripting.Dictionary")
        sArr = .Range("B3:I" & Rws).Value
        R = UBound(sArr)
    ReDim dArr(1 To R, 1 To 100)
    K = 1
    col = 1
    dArr(K, 1) = "TT"
    dArr(K, 2) = .Range("B2").Value
    For i = 1 To R
        If sArr(i, 1) <> Empty Then
            Txt = sArr(i, 1) & "#"
            If Not Dic.Exists(Txt) Then
                K = K + 1
                Dic.Item(Txt) = K
                dArr(K, 1) = K - 1
                dArr(K, 2) = sArr(i, 1)
            End If
            If Not Dic.Exists(sArr(i, 2)) Then
                col = col + 1
                Dic.Item(sArr(i, 2)) = col
                dArr(1, col + 1) = sArr(i, 2)
            End If
            xRow = Dic.Item(Txt)
            xCol = Dic.Item(sArr(i, 2)) + 1
            dArr(xRow, xCol) = dArr(xRow, xCol) + sArr(i, 4)
        End If
    Next i
    .Range("L3").Resize(1000, 100).ClearContents
    .Range("L3").Resize(1000, 100).Borders.LineStyle = 0
    .Range("L3").Resize(K, col).Borders.LineStyle = 1
    .Range("M3").Resize(K).NumberFormat = "m/d/yyyy"
    .Range("L3").Resize(K, col) = dArr
End With
End Sub
 

File đính kèm

  • Hoa don (1).xlsb
    33.3 KB · Đọc: 4
Lần chỉnh sửa cuối:
Upvote 0
chiendich đã viết:
Nhờ anh @giaiphap sửa code tương tự bị thiếu mất 1 dòng và sắp xếp tên sản phẩm theo thứ tự tăng dần giúp em với !
Mã: 
Public Sub GPE()
Dim Dic As Object, sArr(), dArr(), Txt As String
Dim i As Long, K As Long, R As Long, Rws As Long, col As Long, xRow As Long, xCol As Long
With Sheets("Sheet1")
    Rws = .Range("B10000").End(xlUp).Row
    If Rws < 3 Then Exit Sub
    Set Dic = CreateObject("Scripting.Dictionary")
        sArr = .Range("B3:I" & Rws).Value
        R = UBound(sArr)
    ReDim dArr(1 To R, 1 To 100)
    K = 1
    col = 1
    dArr(K, 1) = "TT"
    dArr(K, 2) = .Range("B2").Value
    For i = 1 To R
        If sArr(i, 1) <> Empty Then
            Txt = sArr(i, 1) & "#"
            If Not Dic.Exists(Txt) Then
                K = K + 1
                Dic.Item(Txt) = K
                dArr(K, 1) = K - 1
                dArr(K, 2) = sArr(i, 1)
            End If
            If Not Dic.Exists(sArr(i, 2)) Then
                col = col + 1
                Dic.Item(sArr(i, 2)) = col
                dArr(1, col + 1) = sArr(i, 2)
            End If
            xRow = Dic.Item(Txt)
            xCol = Dic.Item(sArr(i, 2)) + 1
            dArr(xRow, xCol) = dArr(xRow, xCol) + sArr(i, 4)
        End If
    Next i
    .Range("L3").Resize(1000, 100).ClearContents
    .Range("L3").Resize(1000, 100).Borders.LineStyle = 0
    .Range("L3").Resize(K, col).Borders.LineStyle = 1
    .Range("M3").Resize(K).NumberFormat = "m/d/yyyy"
    .Range("L3").Resize(K, col) = dArr
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Thêm lệnh này phía dưới Next i, mình đang bị nhầm ở chổ Col phải thêm 2 đơn vị do cột TT và cột ngày.
Mã: 
col = col + 1
 
Upvote 0
Đây là cách trích xuất kết quả 1 tuần, bắt đầu từ 1 thứ hai nào đó trong danh sách ngày (toàn thứ hai)
 

File đính kèm

  • Dictionary.rar
    22 KB · Đọc: 6
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

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
190
Đọc
10K
Hoàng Tuấn 868
H
P
Sự cố về hàm SUMIF
Trả lời
8
Đọc
206
yeudoi
yeudoi
S
Chuyển định dạng thời gian từ sa/ch sang AM/PM
Trả lời
2
Đọc
46
Silklynk
S
B
Nhờ anh/chị giúp em tìm hàm cho công thức tính lương
Trả lời
3
Đọc
121
kienpham08
K
hoaithanh9480
Nhờ giúp đỡ về kiểm phiếu bầu
Trả lời
5
Đọc
84
kienpham08
K
thlpro
Truy Vấn Công thức từ Sheet này Qua Sheet Khác
Trả lời
0
Đọc
62
thlpro
thlpro
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
130
nguyenthieny
N
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
8
Đọc
383
DeTong
D
N
  • Question
VBA - copy các sheets unhide và dạng giá trị theo vùng xác định
Trả lời
2
Đọc
67
bebo021999
B
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
86
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
279
viethung78
V
N
cộng các dữ liệu không trùng nhau
Trả lời
13
Đọc
232
DeTong
D
T
Lỗi import dữ liệu
Trả lời
1
Đọc
43
ongke0711
ongke0711
Huy@@*
Giải đáp giùm em, cách khắc phục lỗi này trên VBA
2
Trả lời
28
Đọc
375
ptm0412
ptm0412
E
  • Question
Tạo bảng lọc theo điều kiện
Trả lời
7
Đọc
155
Hoàng Tuấn 868
H
Bùi Thúy Thúy
  • Question
Lấy dữ liệu thời tiết Accuweather để điền vào nhật ký thi công
2 3 4
Trả lời
62
Đọc
18K
HeSanbi
HeSanbi
vova2209
Index kết hợp với match 2 điều kiện
Trả lời
14
Đọc
1K
dunghtgiga
dunghtgiga
D
  • Question
Xin cách tạo tab và button cho Add-in trên ribbon Maintabs
Trả lời
2
Đọc
111
Decepticon
D
T
Chèn dữ liệu từ sheet này qua sheet khác theo điều kiện
Trả lời
3
Đọc
150
HieuCD
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

Back
Top Bottom