Tham chiếu chuỗi điều kiện để trả về kết quả

soledad_90 · 29/9/22

Em chào diễn đàn.
Em có file dữ liệu với các sh Data / sh LSX/ sh XuatKho
Mong sự giúp đỡ cho code trả về kết quả tại sh XuatKho với các điều kiện :

Em có diễn giải trong file và Kết quả mẫu làm tay
Em cảm ơn!

anhtuan2939 · 29/9/22

soledad_90 đã viết:
Em chào diễn đàn.
Em có file dữ liệu với các sh Data / sh LSX/ sh XuatKho
Mong sự giúp đỡ cho code trả về kết quả tại sh XuatKho với các điều kiện :
View attachment 281478
Em có diễn giải trong file và Kết quả mẫu làm tay
Em cảm ơn!

Bạn thử code này xem

PHP:

Sub Loc()
    Dim dict As Object, sArr(), dArr()
    Dim i As Long, R As Long, Row As Long, lr As Long, j    As Integer
    Dim tmp As String
   
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
   
    With Sheets("LSX")
        lr = .Range("E" & Rows.Count).End(xlUp).Row
        sArr = .Range("C3:H" & lr).Value2
        Row = UBound(sArr, 1)
        ReDim dArr(1 To Row, 1 To 9)
        For i = 1 To Row
            tmp = sArr(i, 3) & sArr(i, 4) & sArr(i, 5)
            dict.Add tmp, i
            For j = 1 To 5
                dArr(i, j) = sArr(i, j)
            Next j
        Next i
    End With
   
    With Sheets("Data")
        lr = .Range("D" & Rows.Count).End(xlUp).Row
        sArr = .Range("C4:J" & lr).Value2
        For i = 1 To UBound(sArr)
            tmp = sArr(i, 2) & sArr(i, 3) & sArr(i, 4)
            If dict.Exists(tmp) Then
                R = dict.Item(tmp)
                For j = 1 To 4
                    dArr(R, j + 5) = sArr(i, j + 4)
                Next j
            End If
        Next i
    End With
   
    With Sheets("Xuatkho")
        .Range("C3:K10000").ClearContents
        .Range("C3").Resize(Row, 9).Value = dArr
    End With
   
    Set dict = Nothing
End Sub

soledad_90 · 29/9/22

anhtuan2939 đã viết:

Bạn thử code này xem

PHP:

Sub Loc()
    Dim dict As Object, sArr(), dArr()
    Dim i As Long, R As Long, Row As Long, lr As Long, j    As Integer
    Dim tmp As String
  
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
  
    With Sheets("LSX")
        lr = .Range("E" & Rows.Count).End(xlUp).Row
        sArr = .Range("C3:H" & lr).Value2
        Row = UBound(sArr, 1)
        ReDim dArr(1 To Row, 1 To 9)
        For i = 1 To Row
            tmp = sArr(i, 3) & sArr(i, 4) & sArr(i, 5)
            dict.Add tmp, i
            For j = 1 To 5
                dArr(i, j) = sArr(i, j)
            Next j
        Next i
    End With
  
    With Sheets("Data")
        lr = .Range("D" & Rows.Count).End(xlUp).Row
        sArr = .Range("C4:J" & lr).Value2
        For i = 1 To UBound(sArr)
            tmp = sArr(i, 2) & sArr(i, 3) & sArr(i, 4)
            If dict.Exists(tmp) Then
                R = dict.Item(tmp)
                For j = 1 To 4
                    dArr(R, j + 5) = sArr(i, j + 4)
                Next j
            End If
        Next i
    End With
  
    With Sheets("Xuatkho")
        .Range("C3:K10000").ClearContents
        .Range("C3").Resize(Row, 9).Value = dArr
    End With
  
    Set dict = Nothing
End Sub

Cảm ơn bạn đã giúp đỡ:
Code cho kết quả còn thiếu bạn à.
VD chuỗi dữ liệu này tại sh Data có 5 giòng dữ liệu
Khi đó sẽ hiện đủ 5 giòng dữ liệu này vào sh Xuatkho . Code bạn mới chỉ hiển thị 1 giá trị

anhtuan2939 · 29/9/22

Bạn thử lại code này xem

PHP:

Sub Loc()
    Dim dict As Object, sArr(), tArr(), dArr()
    Dim i As Long, R, Row As Long, lr As Long, j As Integer
    Dim tmp As String
  
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    With Sheets("Data")
        If .AutoFilterMode = True Then .AutoFilterMode = False
        lr = .Range("D" & Rows.Count).End(xlUp).Row
        tArr = .Range("C4:J" & lr).Value2
        ReDim dArr(1 To UBound(tArr), 1 To 9)
        For i = 1 To UBound(tArr)
            tmp = tArr(i, 2) & tArr(i, 3) & tArr(i, 4)
            If Not dict.Exists(tmp) Then
                dict.Add tmp, i
            Else
                dict.Item(tmp) = dict.Item(tmp) & "#" & i
            End If
        Next i
    End With
  
    With Sheets("LSX")
        lr = .Range("E" & Rows.Count).End(xlUp).Row
        sArr = .Range("C3:H" & lr).Value2
        For i = 1 To UBound(sArr, 1)
            tmp = sArr(i, 3) & sArr(i, 4) & sArr(i, 5)
            If dict.Exists(tmp) Then
                For Each R In Split(dict.Item(tmp), "#")
                    Row = Row + 1
                    dArr(Row, 1) = sArr(i, 1)
                    For j = 1 To 8
                        dArr(Row, j + 1) = tArr(R, j)
                    Next j
                Next
            Else
                Row = Row + 1
                dArr(Row, 1) = sArr(i, 1)
                For j = 1 To 4
                    dArr(Row, j + 1) = sArr(i, j + 1)
                Next j
            End If
        Next i
    End With
  
    With Sheets("Xuatkho")
        .Range("C3:K10000").ClearContents
        .Range("C3").Resize(Row, 9).Value = dArr
    End With
  
    Set dict = Nothing
End Sub

soledad_90 · 29/9/22

anhtuan2939 đã viết:

Bạn thử lại code này xem

PHP:

Sub Loc()
    Dim dict As Object, sArr(), tArr(), dArr()
    Dim i As Long, R, Row As Long, lr As Long, j As Integer
    Dim tmp As String
 
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
   
    With Sheets("Data")
        If .AutoFilterMode = True Then .AutoFilterMode = False
        lr = .Range("D" & Rows.Count).End(xlUp).Row
        tArr = .Range("C4:J" & lr).Value2
        ReDim dArr(1 To UBound(tArr), 1 To 9)
        For i = 1 To UBound(tArr)
            tmp = tArr(i, 2) & tArr(i, 3) & tArr(i, 4)
            If Not dict.Exists(tmp) Then
                dict.Add tmp, i
            Else
                dict.Item(tmp) = dict.Item(tmp) & "#" & i
            End If
        Next i
    End With
 
    With Sheets("LSX")
        lr = .Range("E" & Rows.Count).End(xlUp).Row
        sArr = .Range("C3:H" & lr).Value2
        For i = 1 To UBound(sArr, 1)
            tmp = sArr(i, 3) & sArr(i, 4) & sArr(i, 5)
            If dict.Exists(tmp) Then
                For Each R In Split(dict.Item(tmp), "#")
                    Row = Row + 1
                    dArr(Row, 1) = sArr(i, 1)
                    For j = 1 To 8
                        dArr(Row, j + 1) = tArr(R, j)
                    Next j
                Next
            Else
                Row = Row + 1
                dArr(Row, 1) = sArr(i, 1)
                For j = 1 To 4
                    dArr(Row, j + 1) = sArr(i, j + 1)
                Next j
            End If
        Next i
    End With
 
    With Sheets("Xuatkho")
        .Range("C3:K10000").ClearContents
        .Range("C3").Resize(Row, 9).Value = dArr
    End With
 
    Set dict = Nothing
End Sub

Cảm ơn bạn giúp đỡ
Code cho kết quả theo nhu cầu rồi nhé.

Tham chiếu chuỗi điều kiện để trả về kết quả

soledad_90

Thành viên thường trực

File đính kèm

anhtuan2939

anhtuan2939

Thành viên hoạt động

soledad_90

Thành viên thường trực

anhtuan2939

Thành viên hoạt động

soledad_90

Thành viên thường trự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