Difficult but not impossible

[decent_boy]

Hello, hope that you are well

I need a macro for my result sheet , let me explain you that i have sheet1 and there are 3 fields from col a to c and i need a macro for result sheet which matches ID number from result sheet col a (where DI# is blank in col b) with sheet1 col a and copy/distribute b col value from sheet1 to result sheet in col c which must be equal d col value , ok please see below example in red highlighted font cells as a macro result.

Sheet1
ID	EDI #	Qty
A11	A1245	2
A11	A1345	1
A11	A1545	10
A16	B4567	3
A16	B6789	30

<colgroup><col width="64" span="3" style="width:48pt"> </colgroup><tbody>
</tbody>

Result Sheet
ID	DI#	EDI #	Qty
A11	-	A1245	2
A11	-	A1345	1
A11	-	A1545	1
A12	2345		1
A13	3245		1
A16	-	B4567	3
A16	-	B6789	2
A16	-	B6789	1

<colgroup><col><col><col><col></colgroup><tbody>
</tbody>

 

[decent_boy]

rick i enclosed a example work on below excel forum

Distribute/Copy by Matching Multiple Conditions

 

[decent_boy]

Rick , below solution has been provided on previous post link

Sub Data_base()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim rng2 As Range
Dim LRws1 As Long, LRws3 As Long
Dim chk As Variant
Dim match_formula As Variant


Set ws1 = Sheets("Fruit Data Base")
Set ws2 = Sheets("Fruit Order List")


Application.ScreenUpdating = False


ws1.Copy After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = "Helper_sheet"
     
Set ws3 = Sheets("Helper_sheet")


On Error Resume Next
LRws2 = ws2.UsedRange.Rows.Count
LRws3 = ws3.UsedRange.Rows.Count


Set rng2 = ws2.Range("D3:D" & LRws2)




For Each r In rng2
    If r.Offset(, -1).Value = 0 Or r.Offset(, -1).Value = "-" Then
        r.Value = "!"
        For i = 1 To LRws3
            If ws3.Range("A1").Offset(i).Value = r.Offset(, -2).Value And ws3.Range("A1").Offset(i, 3).Value = r.Offset(, 1).Value Then
            r.Value = ws3.Range("A1").Offset(i, 2).Value
            ws3.Range("A1").Offset(i, 2).EntireRow.Delete
            GoTo Skip1
            End If
        Next i
      End If
Skip1:
Next r


LRws3 = ws3.UsedRange.Rows.Count


For Each r In rng2
    If r.Value = "!" Then
        For i = 1 To LRws3
            If ws3.Range("A1").Offset(i).Value = r.Offset(, -2).Value And ws3.Range("A1").Offset(i, 3).Value > r.Offset(, 1).Value Then
            ws3.Range("A1").Offset(i, 4).Value = ws3.Range("A1").Offset(i, 3).Value - r.Offset(, 1).Value
            End If
        Next i
     
        For i = 1 To LRws3
            If WorksheetFunction.Max(ws3.Range("A1:A" & LRws3).Offset(, 4)) > 0 And ws3.Range("A1").Offset(i, 4).Value = WorksheetFunction.Min(ws3.Range("A1:A" & LRws3).Offset(, 4)) Then
                r.Value = ws3.Range("A1").Offset(i, 2).Value
                ws3.Range("A1").Offset(i, 3).Value = ws3.Range("A1").Offset(i, 4).Value
                ws3.Range("A1:A" & LRws3).Offset(, 4).ClearContents
                GoTo skip2
            End If
        Next i
    End If
skip2:
    
Next r


Application.DisplayAlerts = False
ws3.Delete


Application.DisplayAlerts = True
Application.ScreenUpdating = True


End Sub