Sub Macro()
strFormulaBuyR1C1 = "=IF(AND(RC[-1]=""I"",RC[-2]<RC[4]),RC[-2],IF(RC[-1]<>"""",RC[-2]+(RC[-2]*VLOOKUP(R1C1,Setting!R1C1:R71C2,2,FALSE)),""""))"
strFormulaSellR1C1 = "=IF(AND(RC[-1]=""I"",RC[-2]<RC[-8]),RC[-2],IF(RC[-1]<>"""",RC[-2]-(RC[-2]*VLOOKUP(R1C1,Setting!R1C1:R71C2,2,FALSE)),""""))"
strFormulaPandL_R1C1 = "=IFERROR(IF(AND(RC[-8]<>"""",RC[-2]=""""),(RC[-10]*RC[1])-(RC[-10]*RC[-7]),IF(AND(RC[-8]="""",RC[-2]<>""""),(RC[-4]*RC[-1])-(RC[-4]*RC[1]),(RC[-4]*RC[-1])-(RC[-10]*RC[-7]))),0)"
strFormulaSettlPriceR1C1 = "=IF((RC[-9]=""C"")=(NOT(RC[-3]=""C"")),VLOOKUP(IF(RC[-9]<>"""",RC[-13],IF(RC[-3]<>"""",RC[-7])),SettelmentPrice!R1C1:R500C2,2,FALSE),"""")"
Set OrigSh = Sheets("Posting")
OrigSh.Activate
Set destSh = Sheets(Range("O1").Value)
For Each strType In Array("I", "BOTH", "C")
For Each c1 In Range(Range("Q2"), Range("Q" & Rows.Count).End(xlUp))
If c1.Offset(, 4) = strType Then
dblAmount = c1.Offset(, 2)
For Each c2 In destSh.Range(destSh.Range("G2"), destSh.Range("G" & Rows.Count).End(xlUp))
If dblAmount > 0 And c1 = c2 And destSh.Range("A" & c2.Row) = "" Then
Set newTrans = destSh.Range("A" & c2.Row)
newTrans.Value = c1
newTrans.Offset(, 1).Value = c1.Offset(, 1).Value
newTrans.Offset(, 2) = WorksheetFunction.Min(c1.Offset(, 2), c2.Offset(, 2))
newTrans.Offset(, 3) = c1.Offset(, 3)
strCode = IIf(c1.Offset(, 4) = "BOTH", IIf(c1.Offset(, 1) = c2.Offset(, 1), "I", "C"), c1.Offset(, 4))
newTrans.Offset(, 4) = strCode
dblAmount = dblAmount - c2.Offset(, 2)
newTrans.Offset(, 5).FormulaR1C1 = strFormulaBuyR1C1
End If
Next
If dblAmount > 0 Then
lstRow = LastRow(destSh.Name)
Set newTrans = destSh.Range("A" & lstRow).Offset(1)
newTrans.Value = c1
newTrans.Offset(, 1) = c1.Offset(, 1)
newTrans.Offset(, 2) = dblAmount
newTrans.Offset(, 3) = c1.Offset(, 3)
newTrans.Offset(, 4) = IIf(c1.Offset(, 4) = "I", "I", "C")
newTrans.Offset(, 5).FormulaR1C1 = strFormulaBuyR1C1
destSh.Range("M" & newTrans.Row).FormulaR1C1 = strFormulaPandL_R1C1
destSh.Range("N" & newTrans.Row).FormulaR1C1 = strFormulaSettlPriceR1C1
End If
ElseIf c1.Offset(, 4) = "" Then
Exit For
End If
Next
For Each c1 In Range(Range("V2"), Range("V" & Rows.Count).End(xlUp))
If c1.Offset(, 4) = strType Then
dblAmount = c1.Offset(, 2)
For Each c2 In destSh.Range(destSh.Range("A2"), destSh.Range("A" & Rows.Count).End(xlUp))
If dblAmount > 0 And c1 = c2 And destSh.Range("G" & c2.Row) = "" Then
Set newTrans = destSh.Range("G" & c2.Row)
newTrans.Value = c1
newTrans.Offset(, 1) = c1.Offset(, 1)
newTrans.Offset(, 2) = WorksheetFunction.Min(c1.Offset(, 2), c2.Offset(, 2))
newTrans.Offset(, 3) = c1.Offset(, 3)
strCode = IIf(c1.Offset(, 4) = "BOTH", IIf(c1.Offset(, 1) = c2.Offset(, 1), "I", "C"), c1.Offset(, 4))
newTrans.Offset(, 4) = strCode
dblAmount = dblAmount - c2.Offset(, 2)
newTrans.Offset(, 5).FormulaR1C1 = strFormulaSellR1C1
End If
Next
If dblAmount > 0 Then
lstRow = LastRow(destSh.Name)
Set newTrans = destSh.Range("G" & lstRow).Offset(1)
newTrans.Value = c1
newTrans.Offset(, 1) = c1.Offset(, 1)
newTrans.Offset(, 2) = dblAmount
newTrans.Offset(, 3) = c1.Offset(, 3)
newTrans.Offset(, 4) = IIf(c1.Offset(, 4) = "I", "I", "C")
newTrans.Offset(, 5).FormulaR1C1 = strFormulaSellR1C1
destSh.Range("M" & newTrans.Row).FormulaR1C1 = strFormulaPandL_R1C1
destSh.Range("N" & newTrans.Row).FormulaR1C1 = strFormulaSettlPriceR1C1
End If
ElseIf c1.Offset(, 4) = "" Then
Exit For
End If
Next
Next
End Sub
Function LastRow(sh As String)
On Error Resume Next
LastRow = Sheets(sh).Cells.Find(What:="*", _
After:=Sheets(sh).Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
This is original code i need changes in this as Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.
”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.
Our community of experts have been thoroughly vetted for their expertise and industry experience.
The Distinguished Expert awards are presented to the top veteran and rookie experts to earn the most points in the top 50 topics.