VBA tổng hợp các mã hàng và nhân với kênh

[tieuthubuongbinh]

Chào các tiền bối,

Nhờ mọi người giúp em viết VBA cho bài sau ạ:

1. Sheet 1: mỗi file làm việc của em có danh sách mã hàng khác nhau, giờ em cần tìm 1 danh sách sao cho tất cả các mã hàng đều đủ trong file này. Vd Sheet 1 / Cột A: mã DS có 100 mã, cột B có 80 mã (có mã trùng cột A và mã ko trùng), cột C 120 mã (cũng có trùng và ko trùng).... cột n có n mã...
Giờ em cần sheet 4 cột A sẽ list hết các mã và ko trùng

2. Sheet 2: có 5 kênh => em muốn nhân với danh sách mã hàng sheet 4. vd: có 200 mã sau khi làm bước 1. thì ở sheet 3 sẽ liệt kê 200 mã kênh A2, 200 mã kênh A3.... 200 mã cho kênh n...

3. Sheet 3: đánh số thứ tự toàn bộ dòng hiện ra sau khi làm bước 2.

 

[HieuCD]

Chào các tiền bối,

Nhờ mọi người giúp em viết VBA cho bài sau ạ:

1. Sheet 1: mỗi file làm việc của em có danh sách mã hàng khác nhau, giờ em cần tìm 1 danh sách sao cho tất cả các mã hàng đều đủ trong file này. Vd Sheet 1 / Cột A: mã DS có 100 mã, cột B có 80 mã (có mã trùng cột A và mã ko trùng), cột C 120 mã (cũng có trùng và ko trùng).... cột n có n mã...
Giờ em cần sheet 4 cột A sẽ list hết các mã và ko trùng

2. Sheet 2: có 5 kênh => em muốn nhân với danh sách mã hàng sheet 4. vd: có 200 mã sau khi làm bước 1. thì ở sheet 3 sẽ liệt kê 200 mã kênh A2, 200 mã kênh A3.... 200 mã cho kênh n...

3. Sheet 3: đánh số thứ tự toàn bộ dòng hiện ra sau khi làm bước 2.

Insert Sheet4 và thử code

Sub GhepData()
  Dim Rng As Range, Dic As Object, iKey
  Dim sArr(), tArr(), Res(), Res2()
  Dim i As Long, n As Long, k As Long, ik As Long, sRow As Long, eRow As Long

  Set Rng = Sheet1.UsedRange
  If Rng.Rows.Count < 2 Then MsgBox "Khong co du lieu": Exit Sub
  sArr = Rng.Offset(1).Resize(Rng.Rows.Count - 1).Value
  ReDim Res(1 To UBound(sArr, 1) * UBound(sArr, 2), 1 To 1)
 
  With CreateObject("scripting.dictionary")
    For Each iKey In sArr
      If Len(iKey) > 0 Then
        If .exists(iKey) = False Then
          .Add iKey, ""
          k = k + 1
          Res(k, 1) = iKey
        End If
      End If
    Next iKey
  End With
 
  If k > 0 Then
    With Sheet4
      eRow = .Range("A1000000").End(xlUp).Row
      If eRow > 1 Then .Range("A2:A" & eRow).ClearContents
      .Range("A2").Resize(k) = Res
    End With
    
    tArr = Sheet2.Range("A1:A5").Value
    sRow = UBound(tArr)
    ReDim Res2(1 To k * sRow, 1 To 3)
    For n = 1 To sRow
      For i = 1 To k
        ik = ik + 1:              Res2(ik, 1) = ik
        Res2(ik, 2) = Res(i, 1):  Res2(ik, 3) = tArr(n, 1)
      Next i
    Next n
    eRow = Rows.Count - 1
    If ik > eRow Then
      MsgBox "Nhieu ket qua >> " & eRow
      ik = eRow
    End If
    With Sheet3
      .Range("A2:C" & eRow + 1).ClearContents
      .Range("A2").Resize(ik, 3).Value = Res2
    End With
  End If
End Sub

 

[tieuthubuongbinh]

QUOTE="HieuCD, post: 913916, member: 373036"]
Insert Sheet4 và thử code
[/QUOTE]
Cám ơn bác, em làm được rồi ạ. Nhưng sao khi em xóa hết dữ liệu ở sheet 1 thì sheet 4 vẫn để nguyên danh sách cũ, bác cho em xin cái msgbox "Không có dữ liệu" với ạ

Em xin thêm code ở sheet 5 được ko ạ?
Sheet 5 có số cột và tiêu đề bằng sheet 1 (vd: nếu sheet 1 em thêm tiêu đề cho n cột thì sheet 5 cũng có những cột mới này)
Sau đó, liệt kê những code bị thiếu ở sheet 4 sau khi so sánh cho từng cột tương ứng của sheet 1:
Vd: Đem cột A sheet 1 đi so sánh với sheet 4 và liệt kê mã bị thiếu

 

[HieuCD]

QUOTE="HieuCD, post: 913916, member: 373036"]
Insert Sheet4 và thử code

Cám ơn bác, em làm được rồi ạ. Nhưng sao khi em xóa hết dữ liệu ở sheet 1 thì sheet 4 vẫn để nguyên danh sách cũ, bác cho em xin cái msgbox "Không có dữ liệu" với ạ

Em xin thêm code ở sheet 5 được ko ạ?
Sheet 5 có số cột và tiêu đề bằng sheet 1 (vd: nếu sheet 1 em thêm tiêu đề cho n cột thì sheet 5 cũng có những cột mới này)
Sau đó, liệt kê những code bị thiếu ở sheet 4 sau khi so sánh cho từng cột tương ứng của sheet 1:
Vd: Đem cột A sheet 1 đi so sánh với sheet 4 và liệt kê mã bị thiếu
[/QUOTE]
Sheet4 lấy dữ liệu từ sheet1, nên không thể thiếu
Chỉnh lại code

Sub GhepData()
  Dim Rng As Range, Dic As Object, iKey
  Dim sArr(), tArr(), Res(), Res2()
  Dim i As Long, n As Long, k As Long, ik As Long, sRow As Long, eRow As Long
 
  With Sheet3
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then .Range("A2:C" & eRow).ClearContents
  End With
  With Sheet4
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then .Range("A2:A" & eRow).ClearContents
  End With
 
  Set Rng = Sheet1.UsedRange
  If Rng.Rows.Count < 2 Then MsgBox "Khong co du lieu": Exit Sub
  sArr = Rng.Offset(1).Resize(Rng.Rows.Count - 1).Value
  ReDim Res(1 To UBound(sArr, 1) * UBound(sArr, 2), 1 To 1)
 
  With CreateObject("scripting.dictionary")
    For Each iKey In sArr
      If Len(iKey) > 0 Then
        If .exists(iKey) = False Then
          .Add iKey, ""
          k = k + 1
          Res(k, 1) = iKey
        End If
      End If
    Next iKey
  End With
  If k > 0 Then
    Sheet4.Range("A2").Resize(k) = Res
    
    tArr = Sheet2.Range("A1:A5").Value
    sRow = UBound(tArr)
    ReDim Res2(1 To k * sRow, 1 To 3)
    For n = 1 To sRow
      For i = 1 To k
        ik = ik + 1:              Res2(ik, 1) = ik
        Res2(ik, 2) = Res(i, 1):  Res2(ik, 3) = tArr(n, 1)
      Next i
    Next n
    eRow = Rows.Count - 1
    If ik > eRow Then
      MsgBox "Nhieu ket qua >> " & eRow
      ik = eRow
    End If
    Sheet3.Range("A2").Resize(ik, 3).Value = Res2
  End If
End Sub

 

[be_09]

Dạ, để con giải thích vì sao con cần cách làm này.
1/ Con có vd 10 file báo cáo, mỗi file tại 1 thời điểm tháng/tuần khác nhau mà sẽ có số lượng code khác nhau.
Có 1 file chuẩn chạy từ SAP thì đủ các code, nhưng vì có khi mỗi tuần có code mới thì các file đang làm việc sẽ thiếu code đó, và chưa kể là file dự báo thì ko có code cũ, mà file số thực thì rất nhiều code cũ (bán cho hết hàng), nên khi con cài hàm thì total lại ko bằng nhau (vd File 1 có 10 code thì ra 50 tổng, nhưng file 2 có 8 code thì ra 45 tổng, làm cho con phải đi kiểm tra xem sai ở đâu rất mất thời gian). Nên con tạo ra bài này là để kiểm tra chéo xem các file đang liên kết data tính toán bị thiếu và cần bổ sung các code nào. Dạ đúng là code sẽ đi kèm rất nhiều thông tin khác nữa.
=> bài này sẽ làm ra danh mục sheet 1 mà bác nói ạ là luôn chứa đủ các code (vì con sợ file chuẩn chạy từ SAP có khi họ deactivate 1 code nào đó sẽ ko chạy ra, trong khi vẫn đang cần code này cho dữ liệu quá khứ).

2/ Nhờ bác tư vấn giúp con: nếu con có sheet 2 dài vậy và có những code ra 0 toàn bộ dữ liệu đang tính (vd code đó có doanh số của 2016 mà bây giờ con chỉ tính toán từ 2017 trở đi => con có thể thêm 1 macro để tự xóa các dòng bằng 0 để file ngắn lại hay là đi insert như bác nói (tại con chưa hiểu lắm ý 2 của bác)

Góp ý cho bạn:
1/Tại bài 19 bạn có nêu file chuẩn chạy từ SAP: Tốt nhất là nên đưa file chuẩn lên để mọi người xem và có hiểu cấu trúc mới đề ra phương án thích hợp.
2/ Nếu giải thích như bài 19 thì có thể làm theo hướng sau:
- Gộp 10 File vào lấy tất cả các mã code vào sheet1.
- Nhập tên kênh vào cột A sheet2, nhập số lượng dòng cần Insert vào cột B (dựa vào số lượng tại đây để Insert số dòng cần vào sheet4), gõ số lượng bao nhiêu thì nó Insert bao nhiêu (bạn chơi mỗi thứ đến 200 dòng nên có nhiều dòng thừa không cần thiết).
- Lấy dữ liệu sheet1 vào sheet4, gán code cần vào cột B, lấy kênh và số lượng vào sheet4, Insert số dòng cần và gán cột C.

 

[tieuthubuongbinh]

Sheet 5 có số cột và tiêu đề bằng sheet 1 (vd: nếu sheet 1 em thêm tiêu đề cho n cột thì sheet 5 cũng có những cột mới này)
Sau đó, liệt kê những code bị thiếu ở sheet 4 sau khi so sánh cho từng cột tương ứng của sheet 1:
Vd: Đem cột A sheet 1 đi so sánh với sheet 4 và liệt kê mã bị thiếu

Sheet4 lấy dữ liệu từ sheet1, nên không thể thiếu
Chỉnh lại code

Ý em là sheet 5 liệt kê những code bị thiếu trong từng cột. Vd cột SFC sheet 1 chỉ có a và d, so sánh với sheet 4 thì là bị thiếu b,c,e nên sẽ liệt kê ra ở sheet 5 cột SFC

 

[HieuCD]

Ý em là sheet 5 liệt kê những code bị thiếu trong từng cột. Vd cột SFC sheet 1 chỉ có a và d, so sánh với sheet 4 thì là bị thiếu b,c,e nên sẽ liệt kê ra ở sheet 5 cột SFC
View attachment 215915

Insert Sheet5

Option Explicit

Sub GhepData()
  Dim Rng As Range, Dic As Object, iKey, tmp As String
  Dim sArr(), tArr(), Res(), Res2(), Res3()
  Dim i As Long, j As Long, n As Long, k As Long, ik As Long, sRow As Long, eRow As Long

  With Sheet3
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then .Range("A2:C" & eRow).ClearContents
  End With
  With Sheet4
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then .Range("A2:A" & eRow).ClearContents
  End With
 
  Set Rng = Sheet1.UsedRange
  If Rng.Rows.Count < 2 Then MsgBox "Khong co du lieu": Exit Sub
  sArr = Rng.Offset(1).Resize(Rng.Rows.Count - 1).Value
  ReDim Res(1 To UBound(sArr, 1) * UBound(sArr, 2), 1 To 1)
  ReDim Res3(1 To UBound(sArr, 1) + 1, 1 To UBound(sArr, 2))
 
  With CreateObject("scripting.dictionary")
    For i = 1 To UBound(sArr)
      For j = 1 To UBound(sArr, 2)
        iKey = sArr(i, j)
        If Len(iKey) > 0 Then
          If .exists(iKey) = False Then
            .Add iKey, "," & j & ","
            k = k + 1
            Res(k, 1) = iKey
          Else
            tmp = .Item(iKey)
            If InStr(1, tmp, "," & j & ",") = 0 Then .Item(iKey) = tmp & j & ","
          End If
        End If
      Next j
    Next i
 
    If k > 0 Then
      Sheet4.Range("A2").Resize(k) = Res
    
      tArr = Sheet2.Range("A1:A5").Value
      sRow = UBound(tArr)
      ReDim Res2(1 To k * sRow, 1 To 3)
      For n = 1 To sRow
        For i = 1 To k
          ik = ik + 1:              Res2(ik, 1) = ik
          Res2(ik, 2) = Res(i, 1):  Res2(ik, 3) = tArr(n, 1)
        Next i
      Next n
      eRow = Rows.Count - 1
      If ik > eRow Then
        MsgBox "Nhieu ket qua >> " & eRow
        ik = eRow
      End If
      Sheet3.Range("A2").Resize(ik, 3).Value = Res2
      
      sRow = UBound(Res3)
      For Each iKey In .keys
        tmp = .Item(iKey)
        For j = 1 To UBound(Res3, 2)
          If InStr(1, tmp, "," & j & ",") = 0 Then
            Res3(sRow, j) = Res3(sRow, j) + 1
            Res3(Res3(sRow, j), j) = iKey
          End If
        Next j
      Next iKey
      With Sheet5
        .UsedRange.ClearContents
        .Range("A1").Resize(, UBound(Res3, 2)).Value = Sheet1.Range("A1").Resize(, UBound(Res3, 2)).Value
        .Range("A2").Resize(sRow - 1, UBound(Res3, 2)).Value = Res3
      End With
    End If
  End With
End Sub

 

[LamNA]

Insert Sheet5

Option Explicit

Sub GhepData()
  Dim Rng As Range, Dic As Object, iKey, tmp As String
  Dim sArr(), tArr(), Res(), Res2(), Res3()
  Dim i As Long, j As Long, n As Long, k As Long, ik As Long, sRow As Long, eRow As Long

  With Sheet3
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then .Range("A2:C" & eRow).ClearContents
  End With
  With Sheet4
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then .Range("A2:A" & eRow).ClearContents
  End With

  Set Rng = Sheet1.UsedRange
  If Rng.Rows.Count < 2 Then MsgBox "Khong co du lieu": Exit Sub
  sArr = Rng.Offset(1).Resize(Rng.Rows.Count - 1).Value
  ReDim Res(1 To UBound(sArr, 1) * UBound(sArr, 2), 1 To 1)
  ReDim Res3(1 To UBound(sArr, 1) + 1, 1 To UBound(sArr, 2))

  With CreateObject("scripting.dictionary")
    For i = 1 To UBound(sArr)
      For j = 1 To UBound(sArr, 2)
        iKey = sArr(i, j)
        If Len(iKey) > 0 Then
          If .exists(iKey) = False Then
            .Add iKey, "," & j & ","
            k = k + 1
            Res(k, 1) = iKey
          Else
            tmp = .Item(iKey)
            If InStr(1, tmp, "," & j & ",") = 0 Then .Item(iKey) = tmp & j & ","
          End If
        End If
      Next j
    Next i

    If k > 0 Then
      Sheet4.Range("A2").Resize(k) = Res
   
      tArr = Sheet2.Range("A1:A5").Value
      sRow = UBound(tArr)
      ReDim Res2(1 To k * sRow, 1 To 3)
      For n = 1 To sRow
        For i = 1 To k
          ik = ik + 1:              Res2(ik, 1) = ik
          Res2(ik, 2) = Res(i, 1):  Res2(ik, 3) = tArr(n, 1)
        Next i
      Next n
      eRow = Rows.Count - 1
      If ik > eRow Then
        MsgBox "Nhieu ket qua >> " & eRow
        ik = eRow
      End If
      Sheet3.Range("A2").Resize(ik, 3).Value = Res2
     
      sRow = UBound(Res3)
      For Each iKey In .keys
        tmp = .Item(iKey)
        For j = 1 To UBound(Res3, 2)
          If InStr(1, tmp, "," & j & ",") = 0 Then
            Res3(sRow, j) = Res3(sRow, j) + 1
            Res3(Res3(sRow, j), j) = iKey
          End If
        Next j
      Next iKey
      With Sheet5
        .UsedRange.ClearContents
        .Range("A1").Resize(, UBound(Res3, 2)).Value = Sheet1.Range("A1").Resize(, UBound(Res3, 2)).Value
        .Range("A2").Resize(sRow - 1, UBound(Res3, 2)).Value = Res3
      End With
    End If
  End With
End Sub

Đọc code xong. kaka

 

[tieuthubuongbinh]

Insert Sheet5

Đúng rồi ạ, với cách này thì em ko cần code sheet 4 nữa vì các cột rỗng ở sheet 1 nó tự xuất hiện cả danh sách ko trùng ở sheet 5 luôn.
Cám ơn anh nhiều lắm ạ.

@LamNA mình ko cần uống vì ko cần đọc luôn hihi. Miễn xài được là ok haha. Mình ko biết xíu gì về VBA thành ra vậy đó.

 

[tieuthubuongbinh]

Insert Sheet5

Anh cho em hỏi, nếu mà text là số (vd "1") và number 1. Nó đang hiểu là 2 giá trị ko trùng, có cách ràng cho nó thành trùng ko anh? tại dữ liệu mã hàng của em xuất từ SAP ra nó hay là kiểu text, mà em so với file excel database thì nó là number.
Nếu khắc phục được thì tốt còn ko em xử lý kiểu text hết trước khi chạy macro cũng được ạ.
Code của bác @befaint cũng bị tương tự.

 

[HieuCD]

Anh cho em hỏi, nếu mà text là số (vd "1") và number 1. Nó đang hiểu là 2 giá trị ko trùng, có cách ràng cho nó thành trùng ko anh? tại dữ liệu mã hàng của em xuất từ SAP ra nó hay là kiểu text, mà em so với file excel database thì nó là number.
Nếu khắc phục được thì tốt còn ko em xử lý kiểu text hết trước khi chạy macro cũng được ạ.
Code của bác @befaint cũng bị tương tự.

Khi dùng Dictionary nên chuyển key thành String, tốc độ xử lý sẽ nhanh hơn, ví dụ
iKey = cStr(sArr(i, j))

 

[tieuthubuongbinh]

Góp ý cho bạn:
1/Tại bài 19 bạn có nêu file chuẩn chạy từ SAP: Tốt nhất là nên đưa file chuẩn lên để mọi người xem và có hiểu cấu trúc mới đề ra phương án thích hợp.

Dạ, con gửi bác xem file SAP chạy ra.
Vì file này là toàn bộ các mã của nhiều phòng ban nên con chỉ muốn hiện ra danh sach và các cột con cần ở sheet Database theo filter ở sheet 3!B1
Con nhờ bác viết giúp VBA ạ, để sau đó, còn làm tiếp bước 2 của bác.
File thực có chừng 50k dòng.
PS: Dữ liệu gốc này còn phải chuyển đổi qua các điều kiện khác để cho ra 1 bảng dữ liệu khác, lúc đó con mới dựa trên bảng mới này mà xử lý thông tin về bán hàng.

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

Khi dùng Dictionary nên chuyển key thành String, tốc độ xử lý sẽ nhanh hơn, ví dụ
iKey = cStr(sArr(i, j))

Dạ em ko biết gì về VBA nên em cũng chưa hiểu phải sửa làm sao.
Anh cho em xin thêm 1 sheet 6, liệt kê các mã bị trùng (giống sheet 5 nhưng thay vì code không trùng thì giờ là code bị trùng)
Vì có khi em copy mấy chục ngàn dòng và vì nó chỉ toàn trùng nên sheet 5 lại ko sử dụng được. Mà đi countif rồi lấy ra thì cũng hơi thủ công (mà có khi file nặng quá chạy rất lâu).
Xin lỗi anh vì lúc đầu em ko nghĩ ra mình cần gì, thao tác trên thực tế mới thấy bị vướng và đành xin thêm code. Mong anh thông cảm cho.

 

[HieuCD]

Dạ, con gửi bác xem file SAP chạy ra.
Vì file này là toàn bộ các mã của nhiều phòng ban nên con chỉ muốn hiện ra danh sach và các cột con cần ở sheet Database theo filter ở sheet 3!B1
Con nhờ bác viết giúp VBA ạ, để sau đó, còn làm tiếp bước 2 của bác.
File thực có chừng 50k dòng.
PS: Dữ liệu gốc này còn phải chuyển đổi qua các điều kiện khác để cho ra 1 bảng dữ liệu khác, lúc đó con mới dựa trên bảng mới này mà xử lý thông tin về bán hàng.

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

Dạ em ko biết gì về VBA nên em cũng chưa hiểu phải sửa làm sao.
Anh cho em xin thêm 1 sheet 6, liệt kê các mã bị trùng (giống sheet 5 nhưng thay vì code không trùng thì giờ là code bị trùng)
Vì có khi em copy mấy chục ngàn dòng và vì nó chỉ toàn trùng nên sheet 5 lại ko sử dụng được. Mà đi countif rồi lấy ra thì cũng hơi thủ công (mà có khi file nặng quá chạy rất lâu).
Xin lỗi anh vì lúc đầu em ko nghĩ ra mình cần gì, thao tác trên thực tế mới thấy bị vướng và đành xin thêm code. Mong anh thông cảm cho.

Tạo topic mới và gởi bài lên

 

[tieuthubuongbinh]

Tạo topic mới và gởi bài lên

Dạ để em tách bài. Mà sheet 6 là topic này luôn, anh xem giúp em với ạ