Nhờ giúp đỡ code tìm kiếm và tính tổng

Eric.Shen · 18/5/23

Chào các anh/chị GPE,
Em hiện tại đang có một bài toán cần nhờ các anh/chị giúp đỡ ạ
Em cần tìm các cặp tương ứng, xếp chúng cạnh nhau rồi tính tổng
Cụ thể em có diễn giải ở phần diễn giải
Kính nhờ các anh/chị giúp đỡ ạ

snow25 · 18/5/23

Eric.Shen đã viết:
Chào các anh/chị GPE,
Em hiện tại đang có một bài toán cần nhờ các anh/chị giúp đỡ ạ
Em cần tìm các cặp tương ứng, xếp chúng cạnh nhau rồi tính tổng
Cụ thể em có diễn giải ở phần diễn giải
Kính nhờ các anh/chị giúp đỡ ạ

Trong trường hợp nó có nhiều hơn 1 cặp thì sao bạn.Nó 2 Item 3S.003PA.111

Eric.Shen · 18/5/23

snow25 đã viết:
Trong trường hợp nó có nhiều hơn 1 cặp thì sao bạn.Nó 2 Item 3S.003PA.111

Hiện tại em chỉ thấy có 1 cặp có dữ liệu ở bảng Demand thôi bác ạ, có thể 1 liệu chính có 2 liệu thay thế nhưng chỉ có 1 liệu thay thế xuất hiện trong bảng liệu chính ạ

snow25 · 18/5/23

Eric.Shen đã viết:
Hiện tại em chỉ thấy có 1 cặp có dữ liệu ở bảng Demand thôi bác ạ, có thể 1 liệu chính có 2 liệu thay thế nhưng chỉ có 1 liệu thay thế xuất hiện trong bảng liệu chính ạ

Thử code này xem.

Mã:

Sub sbc()
    Dim i As Long, lr As Long, dic As Object, arr, kq, data, dk As String, a As Long, b As Long, c As Long, j As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("demand")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        data = .Range("A2:H" & lr).Value
        For i = 1 To UBound(data)
            dk = data(i, 1)
            dic.Item(dk) = i
        Next i
    End With
    With Sheets("ALT ")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("B2:C" & lr).Value
        ReDim kq(1 To UBound(arr) * 3, 1 To 8)
    End With
        For i = 1 To UBound(arr)
            dk = arr(i, 2)
            b = dic.Item(dk)
            If b Then
               dk = arr(i, 1)
               c = dic.Item(dk)
               If c Then
                  a = a + 1
                  For j = 1 To 8
                      kq(a, j) = data(b, j)
                  Next j
                  a = a + 1
                  For j = 1 To 8
                      kq(a, j) = data(c, j)
                  Next j
                  a = a + 1
                  kq(a, 1) = data(c, 1)
                  kq(a, 2) = data(c, 2)
                  kq(a, 3) = data(c, 3)
                  kq(a, 4) = kq(a - 1, 4) + kq(a - 2, 4)
                  kq(a, 5) = kq(a - 1, 5) + kq(a - 2, 5)
                  kq(a, 6) = kq(a - 1, 6) + kq(a - 2, 6)
                  kq(a, 7) = kq(a - 1, 7) + kq(a - 2, 7)
                  kq(a, 8) = kq(a - 1, 8) + kq(a - 2, 8)
             End If
          End If
      Next i
   With Sheet3
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        If lr > 8 Then .Range("A9:H" & lr).ClearContents
        If a Then .Range("A9:h9").Resize(a).Value = kq
   End With
   Set dic = Nothing
End Sub

bebo021999 · 18/5/23

Sheet ALT, có khoảng trắng phía sau , delete đi nhé
Sheet Demand, nhấn vô nút "xep cap"

PHP:

Option Explicit
Sub ghepcap()
Dim lr&, i&, j&, k&, rng, res(1 To 100000, 1 To 8)
Dim sum1 As Long, sum2 As Long, sum3 As Long, sum4 As Long, sum5 As Long
Dim dic As Object, key, c As Boolean
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("ALT")
    lr = .Cells(Rows.Count, "B").End(xlUp).Row
    rng = .Range("B2:C" & lr).Value
    For i = 1 To UBound(rng)
        If Not dic.exists(rng(i, 1)) Then dic.Add rng(i, 1), rng(i, 2)
    Next
End With
With Sheets("Demand")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A2:H" & lr).Value
End With
For Each key In dic.keys
    c = False: sum1 = 0: sum2 = 0: sum3 = 0: sum4 = 0: sum5 = 0
    For i = 1 To UBound(rng)
        If rng(i, 1) = dic(key) Then
            k = k + 1
            For j = 1 To UBound(rng, 2)
                res(k, j) = rng(i, j)
            Next
            sum1 = sum1 + rng(i, 4): sum2 = sum2 + rng(i, 5): sum3 = sum3 + rng(i, 6)
            sum4 = sum4 + rng(i, 7): sum5 = sum5 + rng(i, 8)
            c = True
        End If
    Next
    For i = 1 To UBound(rng)
        If rng(i, 1) = key Then
            k = k + 1
            For j = 1 To UBound(rng, 2)
                res(k, j) = rng(i, j)
            Next
            sum1 = sum1 + rng(i, 4): sum2 = sum2 + rng(i, 5): sum3 = sum3 + rng(i, 6)
            sum4 = sum4 + rng(i, 7): sum5 = sum5 + rng(i, 8)
            c = True
        End If
    Next
    If c Then
        k = k + 1: res(k, 1) = key: res(k, 4) = sum1: res(k, 5) = sum2
        res(k, 6) = sum3: res(k, 7) = sum4: res(k, 8) = sum5
    End If
Next
With Sheets("KQ")
    .Activate
    .Range("A9:H10000").ClearContents
    .Range("A9").Resize(k, 8).Value = res
End With
End Sub

Eric.Shen · 18/5/23

snow25 đã viết:

Thử code này xem.

Mã:

Sub sbc()
    Dim i As Long, lr As Long, dic As Object, arr, kq, data, dk As String, a As Long, b As Long, c As Long, j As Long
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("demand")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        data = .Range("A2:H" & lr).Value
        For i = 1 To UBound(data)
            dk = data(i, 1)
            dic.Item(dk) = i
        Next i
    End With
    With Sheets("ALT ")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("B2:C" & lr).Value
        ReDim kq(1 To UBound(arr) * 3, 1 To 8)
    End With
        For i = 1 To UBound(arr)
            dk = arr(i, 2)
            b = dic.Item(dk)
            If b Then
               dk = arr(i, 1)
               c = dic.Item(dk)
               If c Then
                  a = a + 1
                  For j = 1 To 8
                      kq(a, j) = data(b, j)
                  Next j
                  a = a + 1
                  For j = 1 To 8
                      kq(a, j) = data(c, j)
                  Next j
                  a = a + 1
                  kq(a, 1) = data(c, 1)
                  kq(a, 2) = data(c, 2)
                  kq(a, 3) = data(c, 3)
                  kq(a, 4) = kq(a - 1, 4) + kq(a - 2, 4)
                  kq(a, 5) = kq(a - 1, 5) + kq(a - 2, 5)
                  kq(a, 6) = kq(a - 1, 6) + kq(a - 2, 6)
                  kq(a, 7) = kq(a - 1, 7) + kq(a - 2, 7)
                  kq(a, 8) = kq(a - 1, 8) + kq(a - 2, 8)
             End If
          End If
      Next i
   With Sheet3
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        If lr > 8 Then .Range("A9:H" & lr).ClearContents
        If a Then .Range("A9:h9").Resize(a).Value = kq
   End With
   Set dic = Nothing
End Sub

Code đúng rồi bác ạ,
Em có thêm chút mong muốn nữa, mong bác giúp đỡ ạ
Nếu trường hợp không tìm được liệu thay thế thì vẫn cho nó xuất hiện ở phần kết quả ạ và có thể bôi màu hay đánh dấu gì đó giúp em cái dòng thêm mới không ạ
Em cảm ơn bác ạ

Bài đã được tự động gộp: 18/5/23

Bác

bebo021999 đã viết:

Sheet ALT, có khoảng trắng phía sau , delete đi nhé
Sheet Demand, nhấn vô nút "xep cap"

PHP:

Option Explicit
Sub ghepcap()
Dim lr&, i&, j&, k&, rng, res(1 To 100000, 1 To 8)
Dim sum1 As Long, sum2 As Long, sum3 As Long, sum4 As Long, sum5 As Long
Dim dic As Object, key, c As Boolean
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("ALT")
    lr = .Cells(Rows.Count, "B").End(xlUp).Row
    rng = .Range("B2:C" & lr).Value
    For i = 1 To UBound(rng)
        If Not dic.exists(rng(i, 1)) Then dic.Add rng(i, 1), rng(i, 2)
    Next
End With
With Sheets("Demand")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng = .Range("A2:H" & lr).Value
End With
For Each key In dic.keys
    c = False: sum1 = 0: sum2 = 0: sum3 = 0: sum4 = 0: sum5 = 0
    For i = 1 To UBound(rng)
        If rng(i, 1) = dic(key) Then
            k = k + 1
            For j = 1 To UBound(rng, 2)
                res(k, j) = rng(i, j)
            Next
            sum1 = sum1 + rng(i, 4): sum2 = sum2 + rng(i, 5): sum3 = sum3 + rng(i, 6)
            sum4 = sum4 + rng(i, 7): sum5 = sum5 + rng(i, 8)
            c = True
        End If
    Next
    For i = 1 To UBound(rng)
        If rng(i, 1) = key Then
            k = k + 1
            For j = 1 To UBound(rng, 2)
                res(k, j) = rng(i, j)
            Next
            sum1 = sum1 + rng(i, 4): sum2 = sum2 + rng(i, 5): sum3 = sum3 + rng(i, 6)
            sum4 = sum4 + rng(i, 7): sum5 = sum5 + rng(i, 8)
            c = True
        End If
    Next
    If c Then
        k = k + 1: res(k, 1) = key: res(k, 4) = sum1: res(k, 5) = sum2
        res(k, 6) = sum3: res(k, 7) = sum4: res(k, 8) = sum5
    End If
Next
With Sheets("KQ")
    .Activate
    .Range("A9:H10000").ClearContents
    .Range("A9").Resize(k, 8).Value = res
End With
End Sub

Em cảm ơn bác nhiều ạ
Em check thấy cặp 3S.00369.111 - 3S.002UH.111 nó vẫn chưa ra kết quả đúng, bác xem giúp em là tại sao với ạ

bebo021999 · 18/5/23

Eric.Shen đã viết:
Em check thấy cặp 3S.00369.111 - 3S.002UH.111 nó vẫn chưa ra kết quả đúng, bác xem giúp em là tại sao với ạ

Vì item A (UH.111) không tồn tại trong Demand, nhưng item B (369.111) lại có, nên nó sẽ liệt kê item B, sau đó chèn 1 dòng tổng (quy về item A)
Nếu vẫn còn sai thì bạn đánh dấu dòng sai, nhập tay kết quả muốn có vào cột bên cạnh rồi post lên.

Eric.Shen · 18/5/23

V

bebo021999 đã viết:
Vì item A (UH.111) không tồn tại trong Demand, nhưng item B (369.111) lại có, nên nó sẽ liệt kê item B, sau đó chèn 1 dòng tổng (quy về item A)
Nếu vẫn còn sai thì bạn đánh dấu dòng sai, nhập tay kết quả muốn có vào cột bên cạnh rồi post lên.

Vâng, em thấy rồi ạ
Cảm ơn bác rất nhiều!

Nhờ giúp đỡ code tìm kiếm và tính tổng

Eric.Shen

Thành viên chính thức

File đính kèm

snow25

Thành viên gạo cội

Eric.Shen

Thành viên chính thức

snow25

Thành viên gạo cội

bebo021999

Thành viên gạo cội

File đính kèm

Eric.Shen

Thành viên chính thức

bebo021999

Thành viên gạo cội

Eric.Shen

Thành viên chính thức

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