testing following on from last post...
What can young Kyle offer me.....
Code:' The solution from karmapala at excelforum 20 June 2020 ' https://www.excelforum.com/excel-programming-vba-macros/1319768-if-condition-met-then-put-the-remark-between-files.html#post5353174 Sub karmapala() 'Dim arr() As Variant Dim Wb1 As Workbook, Wb2 As Workbook, Sh1 As Worksheet, Sh2 As Worksheet Set Wb1 = Workbooks("1.xls") Set Sh1 = Wb1.Worksheets.Item(1) ' Wb1.Sheets("1-Sheet1") Dim Rng As Range ' For main data range in 1.xls ' Set Rng = Sh1.Range("D2", Sh1.Range("D" & Rows.Count).End(xlUp)) ' This and the next line will error if macro.xlsm is active when the macro is run as Rows.Count will give a much larger number ( 1048576 ) than there are rows in a pre Excel 2007 worksheet ( . ' Set Rng = Sh1.Range(Sh1.Range("D2"), Sh1.Range("D" & Rows.Count).End(xlUp))' Set Rng = Sh1.Range("D2", Sh1.Range("D" & Sh1.Rows.Count).End(xlUp)) Set Wb2 = Workbooks("macro.xlsm") ' Workbooks("Macro.xlsm") Set Sh2 = Wb2.Worksheets.Item(1) ' Wb2.Sheets("Sheet1") Dim X As Long X = 0 Rem 2 In this section we build an array, arr(), of column I values to be ... match Column I of 1.xls with column B of macro.xlsm Dim Cel As Range For Each Cel In Rng Dim arr() As Variant ' This will become the array of column I values to be ... match Column I of 1.xls with column B of macro.xlsm If Cel.Value = Cel.Offset(0, 1).Value And Cel.Value <> Cel.Offset(0, 2).Value Then ' If column D of 1.xls is equal to Column E of 1.xls & column D of 1.xls is not equal to column F of 1.xls Then ... ReDim Preserve arr(X) arr(X) = Cel.Offset(0, 5) ' This is the column I value for ... match Column I of 1.xls with column B of macro.xlsm X = X + 1 ' to make the array element for the next entry, should there be one End If 'If Cel.Value <> Cel.Offset(0, 1) And Cel.Value = Cel.Offset(0, 2) Then If Cel.Value = Cel.Offset(0, 2) And Cel.Value <> Cel.Offset(0, 1) Then ' .... ReDim Preserve arr(X) ReDim Preserve arr(X) arr(X) = Cel.Offset(0, 5) ' This is the column I value for ... match Column I of 1.xls with column B of macro.xlsm End If Next If X = 0 Then Exit Sub Rem 3 In this section we Dim El For Each El In arr() ' arr Dim C Set C = Sh2.Range("B:B").Find(El, lookat:=xlWhole) If Not C Is Nothing Then FirstAddress = C.Address Do If C.Offset(0, 1).Value = "" Then C.Offset(0, 1).Value = 1 Else C.End(xlToRight).Offset(0, 1).Value = C.End(xlToRight).Value + 1 End If Set C = Sh2.Range("B:B").FindNext(C) Loop While C.Address <> FirstAddress End If Next End Sub




Reply With Quote
Bookmarks