VBA how to copy paste specific cells if condition is met, not all row

[aksent1344]

I have a code to copy paste entire row which met condition, but how to copy not entire row, but specific cells from that rows? For example just A, C and D cells from row.

Sub CopyRow_Item()
Application.ScreenUpdating = False
Dim LastRow As Long
Dim last_row As Long
Item = ThisWorkbook.Sheets("Sheet1").Range("B1").Value
LastRow = Sheets("Actuals").Cells.Find("*", SearchOrder:=xlByRows,
SearchDirection:=xlPrevious).Row
last_row = Cells(Rows.Count, "A").End(xlUp).Row
Dim x As Long
x = 1
Dim rng As Range
For Each rng In Sheets("Actuals").Range("A2:A" & LastRow)
If rng = Item Then
rng.EntireRow.Copy
Sheets("Sheet1").Cells(last_row + x, 1).PasteSpecial xlPasteValues
x = x + 1
End If
Next rng


Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[mumps]

Try:

Sub CopyRow_Item()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    Dim last_row As Long
    Item = ThisWorkbook.Sheets("Sheet1").Range("B1").Value
    LastRow = Sheets("Actuals").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    last_row = Cells(Rows.Count, "A").End(xlUp).Row
    Dim x As Long
    x = 1
    Dim rng As Range
    For Each rng In Sheets("Actuals").Range("A2:A" & LastRow)
        If rng = Item Then
            Intersect(rng.Row, Range("A:A,C:D")).Copy
            Sheets("Sheet1").Cells(last_row + x, 1).PasteSpecial xlPasteValues
            x = x + 1
        End If
    Next rng
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[aksent1344]

Try:

Sub CopyRow_Item()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    Dim last_row As Long
    Item = ThisWorkbook.Sheets("Sheet1").Range("B1").Value
    LastRow = Sheets("Actuals").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    last_row = Cells(Rows.Count, "A").End(xlUp).Row
    Dim x As Long
    x = 1
    Dim rng As Range
    For Each rng In Sheets("Actuals").Range("A2:A" & LastRow)
        If rng = Item Then
            Intersect(rng.Row, Range("A:A,C:D")).Copy
            Sheets("Sheet1").Cells(last_row + x, 1).PasteSpecial xlPasteValues
            x = x + 1
        End If
    Next rng
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Got error that is mismatch and Row, is marked

 

[mumps]

It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach screenshots (not a pictures) of your sheets. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[aksent1344]

So In cell B2 I select Item number

Forecast data (version 1).xlsm
	A	B	C	D	E	F	G	H	I	J	K
1	Item No.	00017133
2	Item No.	Type	Item Description	HFB	PA	Unit Volume	Year	Month	Country	POS	Discount Amount
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Sheet1

Cells with Data Validation
Cell	Allow	Criteria
B1	List	=Settings!$A$83:$A$35378
D1	List	=Settings!$B$83:$B$104

And I want that macros take all yellow columns with item number that I selected and paste it in first sheet.

Forecast data (version 1).xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N
1	No.	Product Area No.	Sales Start Date LT	End Date Sale LT	Key article FY22 T2|T3 LT	Quality article FY 22 T2|T3	Recommended Add-on FY22 T2|T3	4A1K FY22 T2|T3 LT	Price FY22 T2 LT	Sold Quantity till W1 LT	Updated 2 Quantity LT T2|T3	Turnover LT T1	Turnover LT T2|T3	Total turnover LT
2	20221449	0731	2013-04-01		X			X	37	5 966	11 716	147 917	358 258	506 175
3	90349326	0522	2017-04-01		X			X	279	856	1 327	162 003	305 978	467 981
4	90204639	0731	2013-04-01		X			X	49	3 757	7 064	124 198	286 063	410 261
5	80524882	0731	2022-01-01		X			X	10	1 231	46 836	9 156	387 074	396 231
6	70389139	7015	2018-08-01		X			X	279	606	932	124 706	214 899	339 605
7	40507342	0351	2021-10-01		X			X	169	607	1 598	74 746	223 192	297 938
8	70213569	0711	2013-04-01		X			X	30	3 820	7 093	94 711	175 860	270 570
9	50214560	0421	2013-04-01	2022-04-01					60	3 369	1 863	167 058	92 380	259 438
10	20481381	0511	2021-10-01		X			X	59	1 135	3 889	55 343	189 629	244 972
11	80275887	0215	2014-06-01		X			X	54,99	2 020	3 454	83 454	156 971	240 426
12	60499954	7023	2021-04-01		X			X	579	163	330	73 956	157 909	231 865
13	90493446	0423	2020-10-01		X			X	299	351	590	80 933	145 793	226 726
14	00263850	0214	2014-06-01		X			X	39	2 220	4 675	71 554	150 682	222 236
15	80214568	0421	2013-04-01	2022-04-01					50	3 576	1 764	147 769	72 893	220 661
16	90234226	1718	2014-02-01		X			X	22,99	1 850	10 142	27 505	192 698	220 203
17	10246308	0422	2014-02-01		X			X	20	5 495	7 777	86 285	128 545	214 831
18	40540054	0421	2022-04-01		X			X	60	-	4 200	-	208 264	208 264
19	40475572	7031	2020-10-01						399	191	450	59 826	148 388	208 214
20	30214504	0422	2013-04-01		X			X	10	9 974	17 003	65 944	140 521	206 464
21	40445392	0113	2018-12-01	2023-04-01	X			X	349	382	382	94 395	110 180	204 575
22	20223882	0111	2013-04-01		X			X	280	399	503	82 438	116 397	198 835
23	00473546	0341	2021-04-01		X				69	1 617	1 862	92 209	106 180	198 389
24	40407922	0423	2019-04-01		X			X	149	663	986	76 163	121 417	197 579
25	60205664	0711	2013-04-01		X	X		X	9	9 372	17 038	69 709	126 729	196 438
26	70261150	0352	2015-04-01		Back-off	X		X	149	617	1 057	65 779	130 160	195 939
27	70496375	7023	2021-04-01		X			X	899	100	169	70 165	125 563	195 728
Sheet3

 

[mumps]

So In cell B2 I select Item number

Did you mean B1 of Sheet1 instead of B2? Is that item number found in column A of Sheet3? Do you want to copy the yellow data from Sheet3 to Sheet1? If that is what you want, the column headers in Sheet3 don't match the headers in Sheet1. Please clarify in detail.

 

[aksent1344]

Ohh sorry, Yes B1. This number should be found in Sheet 3 A column. I want to copy yellow data columns from Sheet 3 to Sheet 1, but just those which has item number equal to Sheet 1 B1 cell.
I know that headers doesn't match exactly.
Adding full table:

Forecast data (version 1).xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U
1	Item No.	00017133
2	Item No.	Type	Item Description	HFB	PA	Unit Volume	Year	Month	Country	POS	Discount Amount	Net Amount	Quantity	Cost Amount	Sales Price	Franchice fee	GP	GM	GM1	GM1%	Deductions
3
4
5
6
7
8
9
10
11
12
13
Sheet1

Cells with Data Validation
Cell	Allow	Criteria
B1	List	=Settings!$A$83:$A$35378
D1	List	=Settings!$B$83:$B$104

A column from sheet 3 should be paste in A column in sheet1
B column from sheet 3 should be paste in E column in sheet1
I column from sheet 3 should be paste in O column in sheet1
K column from sheet 3 should be paste in M column in sheet1
M column from sheet 3 should be paste in L column in sheet1

 

[mumps]

Do you want to copy the data automatically when you enter an item number in B1 or do you want o run the macro manually?

 

[aksent1344]

I want to run macros manually

 

[mumps]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, fnd As Range, colArr As Variant, i As Long
    colArr = Array("A", "A", "B", "E", "I", "O", "K", "M", "M", "L")
    Set desWS = Sheets("Sheet1")
    Set srcWS = Sheets("Sheet3")
    Set fnd = srcWS.Range("A:A").Find(desWS.Range("B1").Value, LookIn:=xlValues, lookat:=xlWhole)
    If Not fnd Is Nothing Then
        For i = LBound(colArr) To UBound(colArr) Step 2
            srcWS.Range(colArr(i) & fnd.Row).Copy desWS.Cells(desWS.Rows.Count, colArr(i + 1)).End(xlUp).Offset(1)
        Next i
    Else
        MsgBox desWS.Range("B1") & " not found."
    End If
    Application.ScreenUpdating = True
End Sub