vba Copy Paste Conditional to put remark 1 2 3 .. etc

**fixer** · 03-22-2020, 01:18 AM

Thnx Alot Doc Sir and Molly Sir
Thnx for ur Great Support sir

**DocAElstein** · 03-22-2020, 02:05 AM

You are welcome.

( Molly is a Lady ( Woman ) - She is not a Sir, She is a Ma'am or Madam )

Thank you Molly, Ma'am

Sir - Man
Ma'am - Woman

**fixer** · 03-22-2020, 09:46 PM

Thnx Doc Sir & Molly Mam For the Great Help

**Molly Brennholz** · 03-22-2020, 10:19 PM

Glad you got the answer eventually

**fixer** · 04-29-2020, 12:03 AM

If column B of 2.xlsm match with column B of 1.xls then paste the data from column C of 2.xls as 1,2,3,4,5 and so on....
&
If column B of 2.xlsm doesn't match with column B of 1.xls then delete all the data from column C of that row

macro will be placed in 2.xlsm
all files re located in different path
sheet name can be anything
plz see the sample file

**Molly Brennholz** · 04-29-2020, 04:37 PM

Hello Vixer.
This is similar to what I did for you before, I think.

Here I have some new explanations for you Here
http://www.excelfox.com/forum/showth...ll=1#post13165
http://www.excelfox.com/forum/showth...ll=1#post13164

Before:

_____ Workbook: 1.xlsx ( Using Excel 2007 32 bit )

_Row\^Col	A	B	C	D	E	F
1	NSE	25	6	>	50000	A
2	NSE	22	6	>	10000	A
3	NSE	15083	6	>	70000	A
4	NSE	17388	6	>	20000	A
5	NSE	100	6	>	170000	A
6

Worksheet: Sheet1 (4)

_____ Workbook: 2.xlsm ( Using Excel 2007 32 bit )

_Row\^Col	A	B	C	D	E	F	G
1	Symbol
2	ACC	22	1	2
3	ADANIENT	25	1
4	ADANIPORTS	15083	1	2	3
5	ADANIPOWER	17388	1	2	3	4	5
6	AMARAJABAT	100	1	2	3	4
7	ASIANPAINT	236	1	2
8

Worksheet: Sheet1

now, run macro from here:
http://www.excelfox.com/forum/showth...ll=1#post13166

After results

_____ Workbook: 2.xlsm ( Using Excel 2007 32 bit )

_Row\^Col	A	B	C	D	E	F	G	H
1	Symbol
2	ACC	22	1	2	3
3	ADANIENT	25	1	2
4	ADANIPORTS	15083	1	2	3	4
5	ADANIPOWER	17388	1	2	3	4	5	6
6	AMARAJABAT	100	1	2	3	4	5
7	ASIANPAINT	236
8

Worksheet: Sheet1

Molly

**fixer** · 04-29-2020, 05:20 PM

Yes Molly Mam Actually it requires the modification to increase the output
Sorry for the same Mam But in future there will not be any question similar to this

**Molly Brennholz** · 04-29-2020, 06:48 PM

No need to apologise, I was just making a passing remark, that’s all
It was easy for me to do , because of the simularities to the previous Thread, that's all

.

**fixer** · 05-01-2020, 12:19 AM

Thnx Alot Molly Mam for helping me in solving this problem
Have a Great Day
U have mentioned that ignore that post so till today i have not checked that code but today i thought to check the code if there will be any error i will try to solve it
But the code was perfect

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

I used this vba code and it is giving perfect output if any error u know plz let me know
for me it is working perfect as per my needs