Just testing - ignore this post
TESTING CODE PASTE ERROR
Code:' http://www.excelfox.com/forum/showthread.php/2465-copy-paste-conditional Sub CopyPasterConditionalToPut[color=green]Remark_1_2_3_etc() '[/color] 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
Bookmarks