Test

[Molly Brennholz]

Full macro for this post,

Sub CopyPasterConditionalToPutRemark_1_2_3_etcArseOverTit()

'  http://www.excelfox.com/forum/showthread.php/2465-copy-paste-conditional

'  http://www.excelfox.com/forum/showthread.php/2465-copy-paste-conditional?p=13175&viewfull=1#post13175
Sub CopyPasterConditionalToPutRemark_1_2_3_etcArseOverTit() '
Rem 1 Worksheets info
Dim Wb1 As Workbook, Wb2 As Workbook, Ws1 As Worksheet, Ws2 As Worksheet
 Set Wb1 = Workbooks("1 1Mai.xlsx")
 Set Wb2 = ThisWorkbook   '   macro will be placed in 2.xlsm
 Set Ws1 = Wb1.Worksheets.Item(1): Set Ws2 = Wb2.Worksheets.Item(1)
Rem 2 data Input
Dim arr1() As Variant, arr2() As Variant, arr3() As Variant
 Let arr1() = Ws1.Range("A1:K" & Ws1.Range("A1").CurrentRegion.Rows.Count & "").Value
 Let arr2() = Ws2.Range("A1").CurrentRegion.Value                                     ' Current region will not work for arrS1() because columns G to J are empty
'2b
 ReDim arr3(0 To UBound(arr2(), 1)) ' A 1 dimension array of arrays , ( the first element arr3(0) we will not use )
''2b(i)
' Let arrS3(1) = Ws3.Range("A" & Ws3.Range("A1").CurrentRegion.Columns.Count & "") ' header row as a one dimensional array
''2b(ii) data rows array output
Rem 3
Dim Cnt
    For Cnt = 2 To UBound(arr2(), 1) '  "row" count, Cnt from after heading untill last row in  2.xlsm ( Ws2 )
    '2b)(ii) make and fill the row element array inside the current arr3(cnt) element
    Dim Lc As Long: Let Lc = Ws2.Cells.Item(Cnt, Ws2.Cells.Columns.Count).End(xlToLeft).Column ' last column in this row cnt
     Let arr3(Cnt - 1) = Ws2.Range("A" & Cnt & ":" & CL(Lc + 1) & Cnt & "").Value ' - returns an array of 1 "row" into this element of the array of arrays. It has one more element than filled columns - this empty last element is filled in the next line
     Let arr3(Cnt - 1)(1, UBound(arr3(Cnt - 1), 2)) = UBound(arr3(Cnt - 1), 2) - 2 ' this puts the next integer in the last, currently empty element
    '3a) Check for match criteria
    Dim mtchRes As Variant
     Let mtchRes = Application.Match(arr2(Cnt, 2), Ws1.Range("B1:B" & UBound(arr1(), 1) & ""), 0)
        If IsError(mtchRes) Then  '  If the last line errored than we did not find a match, so we do not need to  do anything to the array
        ' a match was not found, so we do not need to remove the  1   2   3   etc...
        Else
        ' a match was found, so we need to remove the  1   2   3   etc...
        Dim Empt As Long
            For Empt = 3 To UBound(arr3(Cnt - 1), 2)
             Let arr3(Cnt - 1)(1, Empt) = ""
            Next Empt
        End If
    '3c) Paste out row
     Let Ws2.Range("A" & Cnt & "").Resize(1, Lc + 1).Value = arr3(Cnt - 1)
    Next Cnt
                                                                                                                        Rem 4    ....and after putting the remark clear sheet 1 and sheet 2
                                                                                                                        ' Ws1.Cells.Clear
                                                                                                                        ' Ws2.Cells.Clear
End Sub



















'     http://www.excelfox.com/forum/showthread.php/1546-TESTING-Column-Letter-test-Sort
Public Function CL(ByVal lclm As Long) As String '         http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
    Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function

[Molly Brennholz]

Test



askfasfjf

can I post in firefox
Yes... looks like Google Chrome is quirky ( IE as well, but that always was ) ... https screws it up again I expect

x

[Molly Brennholz]

Macro needed , working on the Before of thee last post, which will produce the After of the last post
Macro to solve this Thread : https://excelfox.com/forum/showthrea...-with-Matching
https://excelfox.com/forum/showthrea...ll=1#post13414

'                Conditionally Copy & Paste of the data with increasing series with Matching
Sub Step15() '   https://excelfox.com/forum/showthread.php/2498-Conditionally-Copy-amp-Paste-of-the-data-with-increasing-series-with-Matching
Rem worksheets info
'  ap.xls
Dim Wbap As Workbook
 Set Wbap = Workbooks("ap.xls")
Dim Wsap As Worksheet
 Set Wsap = Wbap.Worksheets.Item(1)
Dim Lrap As Long: Let Lrap = Wsap.Range("E" & Wsap.Rows.Count & "").End(xlUp).Row
Dim Arrap As Variant: Let Arrap = Wsap.Range("A1:Y" & Lrap & "").Value2
'  Book1.xlsm
Dim Wb1 As Workbook
 Set Wb1 = ThisWorkbook
Dim Ws1 As Worksheet, Ws3 As Worksheet
 Set Ws1 = Wb1.Worksheets.Item(1): Set Ws3 = Wb1.Worksheets.Item(3)
Dim Lr1 As Long: Let Lr1 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = Ws1.Range("A1:A" & Lr1 & "").Value2  '         column A of sheet1 of Book1.xlsm
Dim arrC() As Variant: Let arrC() = Ws1.Range("C1:C" & Lr1 & "").Value2  '         column C of sheet1 of Book1.xlsm
Dim Lr3 As Long: Let Lr3 = Ws1.Range("A" & Ws1.Rows.Count & "").End(xlUp).Row
Dim arrA3() As Variant: Let arrA3() = Ws3.Range("A1:A" & Lr1 & "").Value2 '        column A of sheet3 of Book1.xlsm
Rem We have to look on Column S of ap.xls and If column S of ap.xls has negative numbers then
Dim Cnt As Long
    For Cnt = 2 To Lrap ' going down rows in ap worksheet 1
        If Arrap(Cnt, 19) < 0 Then '  If column S of ap.xls has negative numbers then
        Dim Eap As String: Let Eap = Arrap(Cnt, 5) ' then we have to look on Column E of ap.xls  -  Column E data
        Dim mtchRes As Variant ' & we will match that Column E data of ap.xls with column A of sheet1 of Book1.xlsm
         Let mtchRes = Application.Match(Eap, arrA(), 0)
            If IsError(mtchRes) Then
            ' no match
            Else ' see whether column C of Book1.xlsm has data in it or not
                If arrC(mtchRes, 1) = "" Then
                Dim mtchRes3 As Variant '  go to sheet3 of Book1.xlsm and we will look for a match of Column E data of ap.xls with column A of sheet3 of Book1.xlsm
                Let mtchRes3 = Application.Match(Eap, arrA3(), 0)
                    If IsError(mtchRes3) Then
                    ' no match
                    Else
                    Dim Lc As Long: Let Lc = Ws3.Cells.Item(mtchRes3, Ws3.Cells.Columns.Count).End(xlToLeft).Column
                    Dim arr3() As Variant
                     Let arr3() = Ws3.Range("A" & mtchRes & ":" & CL(Lc + 1) & mtchRes & "").Value ' An array for all data of that row in sheet3 and an extra column
                     Let arr3(1, UBound(arr3, 2)) = UBound(arr3(), 2) - 2 ' this puts the next integer in the last, currently empty element    ............ increase one more number in series in it
                    '  we will copy the data from sheet3 of Book1.xlsm and paste it to sheet1 of book1.xlsm   & we ...................................      increase one more number in series in it
                    '  Paste out row
                     Let Ws1.Range("A" & mtchRes & "").Resize(1, Lc + 1).Value = arr3()
                    End If
                Else '  column c has data in it
                ' do nothing
                End If
                
            End If
            
        Else ' not a negative in S column
        
        End If
    
    
    
    Next Cnt
End Sub
'
'     http://www.excelfox.com/forum/showthread.php/1546-TESTING-Column-Letter-test-Sort
Public Function CL(ByVal lclm As Long) As String '         http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
    Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function

---

Macro is also in Book1.xlsm
Share ‘Book1.xlsm’ : https://app.box.com/s/qotw65wmiq1aln7frg9o5gys8ke1l8xh
Share ‘ap.xls’ : https://app.box.com/s/r0tc0hkwoxrqjsqfu4gh7eqyy5jmqlg2

[Molly Brennholz]

testing following on from last post...

What can young Kyle offer me.....

'   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