Giúp đỡ tạo code gộp chung tên gọi hàng hóa

laogiahamvui · 30/9/19

Giúp em Gộp chung tên gọi sản phẩm vào dòng trống trong file đính kèm, trong file em có thể hiện rõ nội dung. Em cảm ơn!

HieuCD · 1/10/19

laogiahamvui đã viết:
Giúp em Gộp chung tên gọi sản phẩm vào dòng trống trong file đính kèm, trong file em có thể hiện rõ nội dung. Em cảm ơn!

Dùng 1 sub, kết quả ở sheet2

Mã:

Sub SubTotal()
  Dim sArr(), Res(), QuocGia
  Dim i&, j&, k&, sRow&, n&, SubTong As Double, Tong As Double
  Dim XuatXu As String
  Const strXuatXu As String = "Trai cay xuat xu"
  Const strTotal As String = " Total"
  Const SoNhom As Long = 1000 'So nhom san pham
 
  QuocGia = Array("My", "Chile", "Canada", "Anh", "Phap", "Vietnam", "Thailand", "Campuchia", "Malaysia", "Indonexia")
  n = UBound(QuocGia)
  With Sheet1
    i = .Range("A1000000").End(xlUp).Row
    If i < 3 Then MsgBox ("khong co du lieu"): Exit Sub
    .Range("A3:C" & i).Sort .Range("B3"), 1, Header:=xlNo 'Sort du lieu
    sArr = .Range("A3:C" & i + 1).Value
  End With
  sRow = UBound(sArr) - 1
  ReDim Res(1 To sRow + SoNhom + 1, 1 To 3)
  For i = 1 To sRow
    k = k + 1
    For j = 1 To 3
      Res(k, j) = sArr(i, j)
    Next j
    SubTong = SubTong + sArr(i, 3)
    For j = 0 To n
      If sArr(i, 1) Like "*" & QuocGia(j) & "*" Then
        If Not XuatXu Like "*" & QuocGia(j) & "*" Then
          If Len(XuatXu) Then
            XuatXu = XuatXu & ", " & QuocGia(j)
          Else
            XuatXu = " " & QuocGia(j)
          End If
        End If
        Exit For
      End If
    Next j
    If sArr(i, 2) <> sArr(i + 1, 2) Then
      k = k + 1
      Res(k, 1) = strXuatXu & XuatXu
      Res(k, 2) = Res(k - 1, 2) & strTotal
      Res(k, 3) = SubTong
      Tong = Tong + SubTong
      XuatXu = ""
      SubTong = 0
    End If
  Next i
  k = k + 1
  Res(k, 2) = "Grand Total"
  Res(k, 3) = Tong
  Sheet2.Range("A3").Resize(k, 3) = Res
End Sub

laogiahamvui · 1/10/19

Cảm ơn anh HieuCD nhiều !

laogiahamvui · 1/10/19

Anh coi lại giùm khi bổ sung thêm một số tên hàng mới thì Tên hàng gộp chung không chính xác. Cảm ơn a!

HieuCD · 1/10/19

laogiahamvui đã viết:
Anh coi lại giùm khi bổ sung thêm một số tên hàng mới thì Tên hàng gộp chung không chính xác. Cảm ơn a!

1 mặt hàng sao lại xuất xứ từ nhiều nước. Bỏ lệnh Exit For

Mã:

Sub SubTotal()
  Dim sArr(), Res(), QuocGia
  Dim i&, j&, k&, sRow&, n&, SubTong As Double, Tong As Double
  Dim XuatXu As String
  Const strXuatXu As String = "Trai cay xuat xu"
  Const strTotal As String = " Total"
  Const SoNhom As Long = 1000 'So nhom san pham
 
  QuocGia = Array("My", "Chile", "Canada", "Anh", "Phap", "Vietnam", "Thailand", "Campuchia", "Malaysia", "Indonexia")
  n = UBound(QuocGia)
  With Sheet1
    i = .Range("A1000000").End(xlUp).Row
    If i < 3 Then MsgBox ("khong co du lieu"): Exit Sub
    .Range("A3:C" & i).Sort .Range("B3"), 1, Header:=xlNo 'Sort du lieu
    sArr = .Range("A3:C" & i + 1).Value
  End With
  sRow = UBound(sArr) - 1
  ReDim Res(1 To sRow + SoNhom + 1, 1 To 3)
  For i = 1 To sRow
    k = k + 1
    For j = 1 To 3
      Res(k, j) = sArr(i, j)
    Next j
    SubTong = SubTong + sArr(i, 3)
    For j = 0 To n
      If sArr(i, 1) Like "*" & QuocGia(j) & "*" Then
        If Not XuatXu Like "*" & QuocGia(j) & "*" Then
          If Len(XuatXu) Then
            XuatXu = XuatXu & ", " & QuocGia(j)
          Else
            XuatXu = "" & QuocGia(j)
          End If
        End If
        'Exit For
      End If
    Next j
    If sArr(i, 2) <> sArr(i + 1, 2) Then
      k = k + 1
      Res(k, 1) = strXuatXu & " " & XuatXu
      Res(k, 2) = Res(k - 1, 2) & strTotal
      Res(k, 3) = SubTong
      Tong = Tong + SubTong
      XuatXu = ""
      SubTong = 0
    End If
  Next i
  k = k + 1
  Res(k, 2) = "Grand Total"
  Res(k, 3) = Tong
  Sheet2.Range("A3").Resize(k, 3) = Res
End Sub

laogiahamvui · 2/10/19

Sản phẩm cùng qui cách nên tên hàng thể hiện luôn nhiều nước anh.

Bài đã được tự động gộp: 2/10/19

A kiểm tra lại giùm, do lúc đầu nhập tên hàng tiếng Việt không dấu vì phải chuyển đổi mã, nay tên hàng đổi lại thành tiếng Việt có dấu thì chạy code không được. Cảm ơn a!

CHAOQUAY · 2/10/19

laogiahamvui đã viết:
Sản phẩm cùng qui cách nên tên hàng thể hiện luôn nhiều nước anh.

Bài đã được tự động gộp: 2/10/19

A kiểm tra lại giùm, do lúc đầu nhập tên hàng tiếng Việt không dấu vì phải chuyển đổi mã, nay tên hàng đổi lại thành tiếng Việt có dấu thì chạy code không được. Cảm ơn a!

Thử code này. Tạm thời tên các quốc gia cách nhau dấu trắng, nếu muốn cách nhau bởi dấu "," thì phải bổ sung thêm danh sách tên các quốc gia nhập hàng.

Mã:

Sub TongHop()
Dim Nguon
Dim Mang, Tam, Tong
Dim Kq
Dim i, j, k, x, z, t
Nguon = Sheet1.Range("A2", Sheet1.Range("C2").End(xlDown))
x = UBound(Nguon)
z = UBound(Nguon, 2)
With CreateObject("Scripting.Dictionary")
    For i = 2 To x
        If InStr(Nguon(i, 1), ",") Then Nguon(i, 1) = Replace(Nguon(i, 1), ",", "")
        If InStr(Nguon(i, 1), "-") Then Nguon(i, 1) = Replace(Nguon(i, 1), "-", "")
        Mang = Split(Nguon(i, 1))
        t = 0
        For j = 1 To UBound(Mang)
            If IsNumeric(Left(Mang(j), 1)) = False And Len(Mang(j)) > 1 And Left(Mang(j), 1) = UCase(Left(Mang(j), 1)) Then
                Mang(t) = Mang(j)
                t = t + 1
            End If
        Next j
        ReDim Preserve Mang(t - 1)
        If .exists(Nguon(i, 2)) = 0 Then
            .Item(Nguon(i, 2)) = Array(" " & Join(Mang) & " ", Nguon(i, 3))
            Tong = Tong + Nguon(i, 3)
        Else
            Tam = .Item(Nguon(i, 2))
            For j = 0 To t - 1
                If InStr(Tam(0), " " & Mang(j) & " ") = 0 Then
                    Tam(0) = Tam(0) & Mang(j) & " "
                End If
            Next j
            Tam(1) = Tam(1) + Nguon(i, 3)
            .Item(Nguon(i, 2)) = Tam
            Tong = Tong + Nguon(i, 3)
        End If
    Next i
    ReDim Kq(1 To x + .Count + 1, 1 To z)
    For j = 1 To z
        Kq(1, j) = Nguon(1, j)
        Kq(2, j) = Nguon(2, j)
    Next j
    k = 2
    For i = 3 To x
        If Nguon(i, 2) <> Nguon(i - 1, 2) Then
            k = k + 1
            Tam = .Item(Nguon(i - 1, 2))
            Kq(k, 1) = "Tr" & ChrW(225) & "i c" & ChrW(226) & "y xu" & ChrW(7845) & "t " & "x" & ChrW(7913) & " " & Tam(0)
            Kq(k, 3) = Tam(1)
        End If
        k = k + 1
        For j = 1 To z
            Kq(k, j) = Nguon(i, j)
        Next j
    Next i
    Kq(k + 1, 1) = "Tr" & ChrW(225) & "i c" & ChrW(226) & "y xu" & ChrW(7845) & "t " & "x" & ChrW(7913) & " " & .Item(Nguon(x, 2))(0)
    Kq(k + 1, 3) = .Item(Nguon(x, 2))(1)
    Kq(k + 2, 1) = "GranTotal"
    Kq(k + 2, 3) = Tong
End With
With Sheet2
    .UsedRange.Clear
    .Range("A2").Resize(UBound(Kq), UBound(Kq, 2)) = Kq
    .Range("A2").Resize(UBound(Kq), UBound(Kq, 2)).Borders.LineStyle = 1
    .UsedRange.Columns.AutoFit
End With
End Sub

laogiahamvui · 2/10/19

Cảm ơn bạn, nguồn tên hàng do tổng hợp từ nhiều người nên có người viết hoa đầu từ, người viết thường hay hoa toàn bộ. Ví dụ như: Đan Mạch, đan mạch hay ĐAN MẠCH, và thêm nữa xuất xứ không gói gọn trong quốc gia mà còn về từng khu vực như Hà nội, Đà nẵng.... nên vùng dữ liệu tìm kiếm cũng sẽ nhiều. Có bổ sung thêm vùng danh sách bao gồm nhiều kiểu chữ trong Sheet1.Range("G3").End(xlDown), bạn xem lại giùm nhé.

HieuCD · 2/10/19

laogiahamvui đã viết:
Cảm ơn bạn, nguồn tên hàng do tổng hợp từ nhiều người nên có người viết hoa đầu từ, người viết thường hay hoa toàn bộ. Ví dụ như: Đan Mạch, đan mạch hay ĐAN MẠCH, và thêm nữa xuất xứ không gói gọn trong quốc gia mà còn về từng khu vực như Hà nội, Đà nẵng.... nên vùng dữ liệu tìm kiếm cũng sẽ nhiều. Có bổ sung thêm vùng danh sách bao gồm nhiều kiểu chữ trong Sheet1.Range("G3").End(xlDown), bạn xem lại giùm nhé.

mổi địa phương chỉ nên nhập 1 lần

Mã:

Sub SubTotal()
  Dim sArr(), Res(), QuocGia(), strXuatXu$, strQG$
  Dim i&, j&, k&, sRow&, n&, SubTong As Double, Tong As Double
  Dim XuatXu As String
  Const strTotal As String = " Total"
  Const SoNhom As Long = 1000 'So nhom san pham
 
  strXuatXu = "Tr" & ChrW(225) & "i c" & ChrW(226) & "y xu" & ChrW(7845) & "t " & "x" & ChrW(7913)
  With Sheet1
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 3 Then MsgBox ("khong co du lieu"): Exit Sub
    .Range("A3:C" & i).Sort .Range("B3"), 1, Header:=xlNo 'Sort du lieu
    sArr = .Range("A3:C" & i + 1).Value
    QuocGia = .Range("G3", .Range("G" & Rows.Count).End(xlUp)).Value
  End With
  n = UBound(QuocGia)
  For j = 1 To n
    If Len(QuocGia(j, 1)) Then
      QuocGia(j, 1) = Application.Proper(QuocGia(j, 1))
    Else
      QuocGia(j, 1) = "zzz!!!"
    End If
  Next j
  sRow = UBound(sArr) - 1
  ReDim Res(1 To sRow + SoNhom + 1, 1 To 3)
  For i = 1 To sRow
    k = k + 1
    For j = 1 To 3
      Res(k, j) = sArr(i, j)
    Next j
    SubTong = SubTong + sArr(i, 3)
    For j = 1 To n
      strQG = QuocGia(j, 1)
      If InStr(1, sArr(i, 1), strQG, 1) Then
        If InStr(1, XuatXu, strQG, 1) = 0 Then
          If Len(XuatXu) Then
            XuatXu = XuatXu & ", " & strQG
          Else
            XuatXu = "" & strQG
          End If
        End If
      End If
    Next j
    If sArr(i, 2) <> sArr(i + 1, 2) Then
      k = k + 1
      Res(k, 1) = strXuatXu & " " & XuatXu
      Res(k, 2) = Res(k - 1, 2) & strTotal
      Res(k, 3) = SubTong
      Tong = Tong + SubTong
      XuatXu = ""
      SubTong = 0
    End If
  Next i
  k = k + 1
  Res(k, 2) = "Grand Total"
  Res(k, 3) = Tong
  Sheet2.Range("A3").Resize(k, 3) = Res
End Sub

CHAOQUAY · 2/10/19

laogiahamvui đã viết:
Cảm ơn bạn, nguồn tên hàng do tổng hợp từ nhiều người nên có người viết hoa đầu từ, người viết thường hay hoa toàn bộ. Ví dụ như: Đan Mạch, đan mạch hay ĐAN MẠCH, và thêm nữa xuất xứ không gói gọn trong quốc gia mà còn về từng khu vực như Hà nội, Đà nẵng.... nên vùng dữ liệu tìm kiếm cũng sẽ nhiều. Có bổ sung thêm vùng danh sách bao gồm nhiều kiểu chữ trong Sheet1.Range("G3").End(xlDown), bạn xem lại giùm nhé.

Tham khảo code dưới đây.
---
Một số nguồn hàng bị thiếu tên trong danh sách

Mã:

Sub TongHop()
Dim Nguon
Dim QuocGia
Dim Chuoi, Tam, Tong
Dim Kq
Dim i, j, k, x, z, t
Nguon = Sheet1.Range("A2", Sheet1.Range("C2").End(xlDown))
x = UBound(Nguon)
z = UBound(Nguon, 2)
QuocGia = Sheet1.Range("G4").CurrentRegion
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For Each t In QuocGia
        .Item(Trim(t)) = ""
    Next t
    QuocGia = .keys
    
    Sheet3.UsedRange.Clear
    Sheet3.Range("A1") = Join(QuocGia)
    
    .RemoveAll
    k = 1
    ReDim Kq(1 To x * 2, 1 To z)
    For i = 2 To x
        Tong = Tong + Nguon(i, 3)
        If .Count = 0 Then
            k = k + 1
        Else
            If Nguon(i, 2) = Nguon(i - 1, 2) Then
                k = k + 1
            Else
                k = k + 2
            End If
        End If
        For j = 1 To z
            Kq(k, j) = Nguon(i, j)
        Next j
        If .exists(Nguon(i, 2)) = 0 Then
            ReDim Tam(x)
            Tam(i) = Nguon(i, 1)
            .Item(Nguon(i, 2)) = Array(Tam, Nguon(i, 3))
        Else
            Tam = .Item(Nguon(i, 2))
            Tam(0)(i) = Nguon(i, 1)
            Tam(1) = Tam(1) + Nguon(i, 3)
            .Item(Nguon(i, 2)) = Tam
        End If
        If .Count > 1 Then
            If Nguon(i, 2) <> Nguon(i - 1, 2) Or i = x Then
                Tam = .Item(Nguon(i - 1, 2))
                t = Join(Tam(0))
                Chuoi = ""
                For Each j In QuocGia
                    If InStr(1, t, j, 1) Then Chuoi = Chuoi & IIf(Chuoi = "", " ", ", ") & j
                Next j
                If i < x Then
                    j = k - 1
                Else
                    j = k + 1
                End If
                Kq(j, 3) = Tam(1)
                Kq(j, 1) = "Tr" & ChrW(225) & "i c" & ChrW(226) & "y xu" & ChrW(7845) & "t x" & ChrW(7913) & " " & Chuoi
            End If
        End If
    Next i
    Kq(j + 1, 1) = "GrandTotal"
    Kq(j + 1, 3) = Tong
End With
With Sheet2
    .UsedRange.Clear
    .Range("A2").Resize(j + 1, UBound(Kq, 2)) = Kq
    .Range("A2").Resize(j + 1, UBound(Kq, 2)).Borders.LineStyle = 1
    Sheet1.Range("A2:C2").Copy .Range("A2")
    .UsedRange.Columns.AutoFit
End With
End Sub

laogiahamvui · 17/10/19

Lần trước a HieuCD có giúp làm code Gộp chung tên hàng, nay từ Tên hàng gộp chung này giúp em tạo code Thay thế & trích xuất từ hay chuỗi trong câu. Nội dung chi tiết em có ghi rõ trong Sheet1 là thay thế và Sheet2 là trích xuất . Cảm ơn nhiều!

Hoan1985 · 17/2/20

Hành xác HiếuCD quá. Yêu cầu người giúp nên tạo file hoàn chỉnh rồi hãy nhờ

Giúp đỡ tạo code gộp chung tên gọi hàng hóa

laogiahamvui

Thành viên mới

File đính kèm

HieuCD

Chuyên gia GPE

File đính kèm

laogiahamvui

Thành viên mới

laogiahamvui

Thành viên mới

File đính kèm

HieuCD

Chuyên gia GPE

laogiahamvui

Thành viên mới

File đính kèm

CHAOQUAY

Thành viên gắn bó

laogiahamvui

Thành viên mới

File đính kèm

HieuCD

Chuyên gia GPE

File đính kèm

CHAOQUAY

Thành viên gắn bó

laogiahamvui

Thành viên mới

File đính kèm

Hoan1985

Thành viên mới

Bài viết mới nhất

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