Find and copy

[nasir]

I need help on VBA that will prompt users to enter numbers, seperated by comas. When the users clicks OK, the vba will copy the data associated with those numbers in different tabs. The name of the tabs will be the numbers entered by the users in the input box

Excel Workbook
	A	B	C	D
8	0100
9	Object Category	GAAP Category Title	Comptroller Source Group	Comptroller Source Group Title
10		PERSONNEL SERVICES	0011	REGULAR PAY - CONT FULL TIME
11			0012	REGULAR PAY - OTHER
12			0013	ADDITIONAL GROSS PAY
13			0014	FRINGE BENEFITS - CURR PERSONNEL
14			0015	OVERTIME PAY
15			0099	UNKNOWN PAYROLL POSTINGS
16		PERSONNEL SERVICES
17		NON-PERSONNEL SERVICES	0020	SUPPLIES AND MATERIALS
18			0030	ENERGY, COMM. AND BLDG RENTALS
19			0031	TELEPHONE, TELEGRAPH, TELEGRAM, ETC
20			0032	RENTALS - LAND AND STRUCTURES
21			0033	JANITORIAL SERVICES
22			0034	SECURITY SERVICES
23			0035	OCCUPANCY FIXED COSTS
24			0040	OTHER SERVICES AND CHARGES
25			0041	CONTRACTUAL SERVICES - OTHER
26			0070	EQUIPMENT & EQUIPMENT RENTAL
27		NON-PERSONNEL SERVICES
28	0100
29	1359
30	Object Category	GAAP Category Title	Comptroller Source Group	Comptroller Source Group Title
31	01	PERSONNEL SERVICES	0011	REGULAR PAY - CONT FULL TIME
32			0012	REGULAR PAY - OTHER
33			0013	ADDITIONAL GROSS PAY
34			0014	FRINGE BENEFITS - CURR PERSONNEL
35			0015	OVERTIME PAY
36			0099	UNKNOWN PAYROLL POSTINGS
37		PERSONNEL SERVICES
38	02	NON-PERSONNEL SERVICES	0020	SUPPLIES AND MATERIALS
39			0031	TELEPHONE, TELEGRAPH, TELEGRAM, ETC
40			0032	RENTALS - LAND AND STRUCTURES
41			0035	OCCUPANCY FIXED COSTS
42			0040	OTHER SERVICES AND CHARGES
43			0041	CONTRACTUAL SERVICES - OTHER
44			0070	EQUIPMENT & EQUIPMENT RENTAL
45		NON-PERSONNEL SERVICES
46	1359
Page1_1

If the user enters 0100, then the vba will copy:

Excel Workbook
	A	B	C	D	E	F	G
8	0100
9	Object Category	GAAP Category Title	Comptroller Source Group	Comptroller Source Group Title	Appropriation	Current AY Expenditure (Less I-D Adv)
10		PERSONNEL SERVICES	0011	REGULAR PAY - CONT FULL TIME	2,879,113	1,544,694
11			0012	REGULAR PAY - OTHER	96,738	1,061,947
12			0013	ADDITIONAL GROSS PAY	0	106,467
13			0014	FRINGE BENEFITS - CURR PERSONNEL	544,563	494,668
14			0015	OVERTIME PAY	300,000	83,043
15			0099	UNKNOWN PAYROLL POSTINGS	0	0
16		PERSONNEL SERVICES			3,820,414	3,290,820
17		NON-PERSONNEL SERVICES	0020	SUPPLIES AND MATERIALS	155,000	85,467
18			0030	ENERGY, COMM. AND BLDG RENTALS	4,765,536	5,671,744
19			0031	TELEPHONE, TELEGRAPH, TELEGRAM, ETC	97,355	111,026
20			0032	RENTALS - LAND AND STRUCTURES	9,350,784	5,863,092
21			0033	JANITORIAL SERVICES	203,618	142,176
22			0034	SECURITY SERVICES	1,590,686	530,096
23			0035	OCCUPANCY FIXED COSTS	1,179,726	617,718
24			0040	OTHER SERVICES AND CHARGES	1,981,629	994,643
25			0041	CONTRACTUAL SERVICES - OTHER	4,595,796	392,932
26			0070	EQUIPMENT & EQUIPMENT RENTAL	240,000	25,229
27		NON-PERSONNEL SERVICES			24,160,129	14,434,123
28	0100				27,980,543	17,724,943
Page1_1

Thanks

 

[nasir]

I found the following VBA but needs to be tweaked. Any help appreciated.

Thanks
Nasir

 

[nasir]

Oopes, forget the code:
'=====================================================
'- FIND & COPY
'- Brian Baulsom January 2005
'=====================================================
Sub FindHiLight()
Dim MyFind As Variant
Dim MyNewValue As Variant
Dim FoundCell As Object
Dim Counter As Long
'-------------------------------------------------
'- SET SEARCH KEY
MyFind = InputBox("Please insert value to find.")
If MyFind = "" Then End
Counter = 0
'------------------------------------------------ I also want to tweak here so that user can enter multiple number like 0100,1456,1460 etc
'- FIND ALL MATCHING CELLS
On Error Resume Next
Set ws = ActiveSheet
Set FoundCell = ws.Cells.Find(What:=MyFind)
If Not FoundCell Is Nothing Then
FirstAddress = FoundCell.Address
Do
Counter = Counter + 1
'--------------------------------------------
'- what to do if found
Application.ScreenUpdating = False
'Here I need to copy all rows where the number user entered begins and ends


FoundCell.Interior.ColorIndex = 16
'--------------------------------------------
Set FoundCell = ws.Cells.FindNext(FoundCell)
Loop While Not FoundCell Is Nothing _
And FoundCell.Address <> FirstAddress
End If
rsp = MsgBox("Found " & Counter)
End Sub