How to copy and paste the next row VBA Help.

[punnipah]

Hi,All

my code :VBA not working if i want to copy more than 1 Row the word "Com." on column "A" is the row i want to copy
How can i do it please help.

Sub copyrows()
Dim r As Range, f As Range, cell As String
Dim wb As Workbook
Dim sh As Worksheet

Set sh = ThisWorkbook.Sheets("Sheet1")
Set wb = Workbooks.Add
Set r = sh.Range("A:A")
Set f = r.Find("Com.", , xlValues, xlWhole, , , True)
If Not f Is Nothing Then
cell = f.Address
Do
sh.Rows(f.Row + 1).Copy wb.Sheets(1).Range("A" & Rows.Count).End(3)(2)
Set f = r.FindNext(f)
Loop While Not f Is Nothing And f.Address <> cell
End If

wb.SaveAs ThisWorkbook.Path & "\NewBook.xlsx"
End Sub

Test.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE
1
2		Detail Debt Information
3	DMSMA004		Date: 08/03/2023
4			Time: 15:21:58
5
6
7	Cust Acc Num :
8	SA Num :
9	Billing Acc Num :	xxxxx
10	Mobile Num :
11	Invoice Num :
12	Cust / Tax ID :	3119900369657
13	Company Code :
14
15	Com.	Company Type	Tax ID	Cate	Sub Cate	Collec. Segment	CA	CA Name	CIS Type	SA	SA Status	BA	BA Name	Account Name	BA Status	Mobile Num	Mobile Status	Mobile Status Date	Count Mobile	Start Date	End Date	Invoice Num	Month	Due date	Debt Age	Invoice Amount	Current Before VAT	VAT	Good & Service	Total Amount
16	AWN	FBB	xxxxx	R	THA	xxxxx	xxxxx	xxxxx				xxxxx	xxxxx	xxxxx	Active	xxxxx	Suspend - Credit Limit	27/02/2023	1	24/08/2022	23/09/2022	xxxxx	6509	24/10/2022	135	1175.93	1099	76.93	0	1175.93
17	AWN	FBB	xxxxx	R	THA	xxxxx	xxxxx	xxxxx				xxxxx	xxxxx	xxxxx	Active	xxxxx	Suspend - Credit Limit	27/02/2023	1	24/09/2022	23/10/2022	xxxxx	6510	24/11/2022	104	1175.93	1099	76.93	0	1175.93
18	AWN	FBB	xxxxx	R	THA	xxxxx	xxxxx	xxxxx				xxxxx	xxxxx	xxxxx	Active	xxxxx	Suspend - Credit Limit	27/02/2023	1	24/10/2022	23/11/2022	xxxxx	6511	24/12/2022	74	1175.93	1099	76.93	0	1175.93
19	AWN	FBB	xxxxx	R	THA	xxxxx	xxxxx	xxxxx				xxxxx	xxxxx	xxxxx	Active	xxxxx	Suspend - Credit Limit	27/02/2023	1	24/11/2022	23/12/2022	xxxxx	6512	24/01/2023	43	1175.93	1099	76.93	0	1175.93
20	AWN	FBB	xxxxx	R	THA	xxxxx	xxxxx	xxxxx				xxxxx	xxxxx	xxxxx	Active	xxxxx	Suspend - Credit Limit	27/02/2023	1	24/12/2022	23/01/2023	xxxxx	6601	24/02/2023	12	1175.93	1099	76.93	0	1175.93
21	AWN	FBB	xxxxx	R	THA	xxxxx	xxxxx	xxxxx				xxxxx	xxxxx	xxxxx	Active	xxxxx	Suspend - Credit Limit	27/02/2023	1	24/01/2023	23/02/2023	xxxxx	6602	24/03/2023	-16	1175.93	1099	76.93	0	1175.93
22													รวม						6							7055.58	6594	461.58	0	7055.58
23													รวม AWN						6							7055.58	6594	461.58	0	7055.58
24											รวม All Company	1							6							7055.58	6594	461.58	0	7055.58
25		Detail Debt Information
26	DMSMA004		Date: 08/03/2023
27			Time: 15:22:41
28
29
30	Cust Acc Num :
31	SA Num :
32	Billing Acc Num :	32000034797020
33	Mobile Num :
34	Invoice Num :
35	Cust / Tax ID :	3100502755940
36	Company Code :
37
38	Com.	Company Type	Tax ID	Cate	Sub Cate	Collec. Segment	CA	CA Name	CIS Type	SA	SA Status	BA	BA Name	Account Name	BA Status	Mobile Num	Mobile Status	Mobile Status Date	Count Mobile	Start Date	End Date	Invoice Num	Month	Due date	Debt Age	Invoice Amount	Current Before VAT	VAT	Good & Service	Total Amount
39	xxxxx	xxxxx	xxxxx	R	THA	xxxxx	xxxxx	xxxxx				xxxxx	xxxxx	xxxxx	Active	xxxxx	Active	11/12/2022	1	16/09/2022	15/10/2022	xxxxx	6510	07/11/2022	121	560.83	0	0	288.2	288.2
40	xxxxx	xxxxx	xxxxx	R	THA	xxxxx	xxxxx	xxxxx				xxxxx	xxxxx	xxxxx	Active	xxxxx	Active	11/12/2022	1	16/10/2022	15/11/2022	xxxxx	6511	08/12/2022	90	511.93	199	13.93	299	511.93
41	xxxxx	xxxxx	xxxxx	R	THA	xxxxx	xxxxx	xxxxx				xxxxx	xxxxx	xxxxx	Active	xxxxx	Active	11/12/2022	1	16/11/2022	15/12/2022	xxxxx	6512	07/01/2023	60	516.21	203	14.21	299	516.21
42	xxxxx	xxxxx	xxxxx	R	THA	xxxxx	xxxxx	xxxxx				xxxxx	xxxxx	xxxxx	Active	xxxxx	Active	11/12/2022	1	16/12/2022	15/01/2023	xxxxx	6601	07/02/2023	29	511.93	199	13.93	299	511.93
43	xxxxx	xxxxx	xxxxx	R	THA	xxxxx	xxxxx	xxxxx				xxxxx	xxxxx	xxxxx	Active	xxxxx	Active	11/12/2022	1	16/01/2023	15/02/2023	xxxxx	6602	10/03/2023	-2	212.93	199	13.93	0	212.93
44													รวม						5							2313.83	800	56	1185.2	2041.2
45													รวม AWN						5							2313.83	800	56	1185.2	2041.2
46											รวม All Company	1							5							2313.83	800	56	1185.2	2041.2
47		Detail Debt Information
48	DMSMA004		Date: 08/03/2023
49			Time: 15:23:10
50
51
52	Cust Acc Num :
53	SA Num :
54	Billing Acc Num :	xxxxx
55	Mobile Num :
56	Invoice Num :
57	Cust / Tax ID :	3101801263730
58	Company Code :
59
60	Com.	Company Type	Tax ID	Cate	Sub Cate	Collec. Segment	CA	CA Name	CIS Type	SA	SA Status	BA	BA Name	Account Name	BA Status	Mobile Num	Mobile Status	Mobile Status Date	Count Mobile	Start Date	End Date	Invoice Num	Month	Due date	Debt Age	Invoice Amount	Current Before VAT	VAT	Good & Service	Total Amount
61	xxxxx	xxxxx	xxxxx	R	THA	HV15	xxxxx	xxxxx				xxxxx	xxxxx	xxxxx	Active	xxxxx	Active	19/05/2022	1	20/10/2022	19/11/2022	xxxxx	6511	12/12/2022	86	648	279.44	19.56	349	648
62	xxxxx	xxxxx	xxxxx	R	THA	HV15	xxxxx	xxxxx				xxxxx	xxxxx	xxxxx	Active	xxxxx	Active	19/05/2022	1	20/11/2022	19/12/2022	xxxxx	6512	11/01/2023	56	648	279.44	19.56	349	648
63	xxxxx	xxxxx	xxxxx	R	THA	HV15	xxxxx	xxxxx				xxxxx	xxxxx	xxxxx	Active	xxxxx	Active	19/05/2022	1	20/12/2022	19/01/2023	xxxxx	6601	11/02/2023	25	648	279.44	19.56	349	648
64	xxxxx	xxxxx	xxxxx	R	THA	HV15	xxxxx	xxxxx				xxxxx	xxxxx	xxxxx	Active	xxxxx	Active	19/05/2022	1	20/01/2023	19/02/2023	xxxxx	6602	14/03/2023	-6	648	279.44	19.56	349	648
65													รวม						4							2592	1117.76	78.24	1396	2592
66													รวม AWN						4							2592	1117.76	78.24	1396	2592
67											รวม All Company	1							4							2592	1117.76	78.24	1396	2592
68
69
70
Sheet1

 

[James006]

Hi,
Think problem is only located in your Copy instruction ...
You could test

sh.Range(Sheet1.Cells(f.Row + 1, 1), Sheet1.Cells(f.Row + (f.End(xlDown).Row - f.Row), 30)).Copy wb.Sheets(1).Range("A" & Rows.Count).End(3)(2)

 

[Alex Blakenburg]

This doesn't impact you now because you are only doing find and not a replace but or future reference your end of loop condition Loop While Not f Is Nothing And f.Address <> cell doesn't work.
If in this line "Not f is Nothing" is False (ie f is not found) then "f.Address" would not exist and the code would error out.

If you are doing a "replace' then use Not f Is Nothing, since you are not doing a replace use f.Address <> cell

 

[punnipah]

Hi,
Think problem is only located in your Copy instruction ...
You could test

sh.Range(Sheet1.Cells(f.Row + 1, 1), Sheet1.Cells(f.Row + (f.End(xlDown).Row - f.Row), 30)).Copy wb.Sheets(1).Range("A" & Rows.Count).End(3)(2)

Thank you verymuch

 

[James006]

You are welcome

 

[punnipah]

This doesn't impact you now because you are only doing find and not a replace but or future reference your end of loop condition Loop While Not f Is Nothing And f.Address <> cell doesn't work.
If in this line "Not f is Nothing" is False (ie f is not found) then "f.Address" would not exist and the code would error out.

If you are doing a "replace' then use Not f Is Nothing, since you are not doing a replace use f.Address <> cell

Thank you verymuch

You are welcome

@

James006​

i so sorry i trype to Run Macro Again it not working

 

[James006]

Hi,
You have to make sure in your set-up that there is no confusion between :
- sh or Set sh = ThisWorkbook.Sheets("Sheet1")
- Sheet1
- Sheets(1)

 

[punnipah]

Hi,
You have to make sure in your set-up that there is no confusion between :
- sh or Set sh = ThisWorkbook.Sheets("Sheet1")
- Sheet1
- Sheets(1)

Sheet1

Set sh = ActiveWorkbook.Sheets("Sheet1")
Set wb = Workbooks.Add
Set r = sh.Range("A:A")
Set f = r.Find("Com.", , xlValues, xlWhole, , , True)
If Not f Is Nothing Then
cell = f.Address
Do
sh.Range(Sheet1.Cells(f.Row + 1, 1), Sheet1.Cells(f.Row + (f.End(xlDown).Row - f.Row), 30)).Copy wb.Sheets(1).Range("A" & Rows.Count).End(3)(2)
Set f = r.FindNext(f)
Loop While Not f Is Nothing And f.Address <> cell
End If

wb.SaveAs ThisWorkbook.path & "\Datafile.xlsx"

 

[James006]

Sorry but ... just tested the Copy instruction, at my end, and it is working as expected ...