Macro for
http://www.excelfox.com/forum/showth...te-conditional
Code:
' http://www.excelfox.com/forum/showthread.php/2465-copy-paste-conditional
Sub CopyPasterConditionalToPutRemark_1_2_3_etc() '
Rem 1 Worksheets info
Dim Wb1 As Workbook, Wb2 As Workbook, Ws1 As Worksheet, Ws2 As Worksheet
Set Wb1 = Workbooks("1.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 from the 3rd up to the last element need to be rtemoved from the array for this row
Dim Empt As Long
For Empt = 3 To UBound(arr3(Cnt - 1), 2)
Let arr3(Cnt - 1)(1, Empt) = ""
Next Empt
Else
' a match was found, so we do not need to remove the 1 2 3 etc...
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
Share ‘1.xlsx’ : https://app.box.com/s/0yc8icxb03i4vs1h11n20l43frmd52qa
Share ‘2.xlsm’ : https://app.box.com/s/ry312xpb04kwef4wufvvx54qpv1mwai0
Reply With Quote
Originally Posted by DocAElstein
Bookmarks