VBA to copy data from specific cells in numerous worksheets in a workbook to a single worksheet.

[ElBillions]

Hello great minds, I need your assistance.
I'm a cost Control Engineer and I stumbled on this awesome site while searching for assistance online.
I'm working with a workbook that has many worksheets with different names. Each is named according to the equipment that has the information in it.
However, each worksheet has the same kind of table in it. Table headings are equipment tag, Jr number, manpower, duration etc.
I'm new with VBA's and haven't been able to write a code but I need a VBA to copy information from cell B2, C2, D2, E2, F2, I18, L2 and S18 from each worksheet and paste them in cells B2, C2, D2, E2, F2, G2, H2 I2 of a particular worksheet called TRACKER in the same workbook.
The copied info should be pasted such that data from each worksheet takes a row and the next worksheet takes the next blank row etc.
Since I create new worksheets daily, I will like the VBA to update TRACKER worksheet daily.
Kindly assist with this as it would really make my work easier.
Thanks.

 

[JLGWhiz]

Try this

Sub t()
Dim sh As Worksheet, rng As Variant
    For Each sh In ThisWorkbook.Sheets
        If sh.Name <> "TRACKER" Then
            With sh
                rng = Array(.Range("B2"), .Range("C2"), .Range("D2"), .Range("E2"), .Range("F2"), .Range("I18"), .Range("L2"), .Range("S18"))
                For i = LBound(rng) To UBound(rng)
                    If i = LBound(rng) Then
                        rng(i).Copy Sheets("TRACKER").Cells(Rows.Count, 2).End(xlUp)(2).Offset(, i)
                    Else
                        rng(i).Copy Sheets("TRACKER").Cells(Rows.Count, 2).End(xlUp).Offset(, i)
                    End If
                Next
            End With
        End If
    Next
End Sub

 

[ElBillions]

Thanks JLGWhiz.
Thanks for the prompt response.
I ran this on my machine but got and error message saying: "Run-time error 9
Subscript out of range"

 

[JLGWhiz]

Which line of code is highlighted when you click the 'Debug' button? Also, do you have any blank sheets in that workbook?

 

[ElBillions]

Which line of code is highlighted when you click the 'Debug' button? Also, do you have any blank sheets in that workbook?

Thanks JLGWhiz.
My apologies for the delayed response: was actally in an area of my work where devices are not allowed.
I tried again and it did actually copy.
However, for cells that contain results of calculations, it returned REF on the TRACKER worksheet.
Please see the mini sheet below.
Also, for some worksheets, it didnt capture anything from the specified cells.

CCV WELDERS & FABRICATIONS 22.xlsm
	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V
1			CSU-3/4/5	C	RV-041 OUTLET LINE	#REF!	#REF!	#REF!
2	1-E-1104B RICH/LEAN AMINE EXCHANGER TO REMOVE LEAKING HEAT EXCHANGER AND REPLACE WITH NEWLY REFURBISHED ONE
3	692699
4	Perforation and corrosion,Damaned gate lock observed om HEAT EXCHANGER AND REPLACE WITH NEWLY REFURBISHED ONE
5	1-E-1104B RICH/LEAN AMINE EXCHANGER TO REMOVE LEAKING HEAT EXCHANGER AND REPLACE WITH NEWLY REFURBISHED ONE		1-E-1104B	PMD	1-E-1104B RICH/LEAN	#REF!	#REF!	#REF!
6	SCRAPPING OF 40FT & 20FT CONTAINER AT THE ADMIN BLOCK
7	HEATING, CUTTING AND WELDING IA WORKSHOP FOR 1P-1550/B
8	TRAIN 1 GEARBOX FAN HUB HEATING
9	FABRICATE AND INSTALL CANOPY AT IA FIRE STATION
10	FABRICATE 2 NO ELECTRICAL PANEL COVER FOR SHUTDOWN ARENA
11	FABRICATE 2 NO ELECTRICAL PANEL COVER FOR SHUTDOWN ARENA
12	FABRICATE 2 UNIT OF TV STAND FOR PMF OFFICE
13	2/3" CONDENSATE DRAIN HEADER FROM 1-6V-1201 TO UNIT 2000
14	FABRICATE AND INSTAL TOWING BAR AT THE AIRSTRIP HILUX FOR LUGGAGE HAULAGE
15	FABRICATE 6 NOS TURNDISH FOR TRAIN 1/2/3/4/5/6V-1106 HYDROCARBON SKIM POT
16	SCRAP 20 NOS 40FT CONTAINERS AT H-BLOCK
17	TRANSFER TOW BAR FROM TRUCK EKY 971 XA TO TRUCK LSD 37 AM
18	REPAIR OF CORRODED HANDRAIL AND MESH COVER OF THE ISB/OSB PONTOON
19	PRE-FABRICATION OFCORRODED STEM COVER FOR BLOCK VALVE
20	FABRICATE 5" & 6" PIPE SPOOLS FOR AKIAMA WATER PLANT.
21
TRACKER

Cell Formulas
Range	Formula
G1,I5,G5,I1	G1	=SUM(#REF!)
H1,H5	H1	=G1*F1*E1

The workbook is such that results of calculations in worksheet 1, for example are copied and linked to a form in worksheet 2 and this occurs for multiple worksheets in that patern: ws 1 copied to ws 2, ws 3 copied to ws 4, ws 5 copied to ws 6 etc. But note that the ws names are not 1,2,3,4,5 etc. They are actually different in the workbook.
My bad. i should have mentioned that i need the VBA to only copy cells fro ws 1,3,5,7 etc in that pattern .
Kindly add this, if possible, while updating this VBA.
Below is a mini sheet of one of the ws the VBA is to copy from.

CCV WELDERS & FABRICATIONS 22.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S
1	S/N	WORK DESCRIPTION	JOB NO.	TAG NO.	AREA	EQUIP. DESCRIPTION	DISCIPLINE	CATEGORY	NOS.	HRS	DAYS	DURATN HRS	RATE	WEIGHT ON RATE	CREW RATE	AMOUNT	SITE FACTOR (SF)	AMOUNT BY SF	TOTAL
2	1		683569	CIV-H3401		JETTY 1	FAB/WELDERS	FAB SUPERVOR	1	14	2	28	########	0.20	684.60	########	2.00	########	########
3								FABRICATOR	1	14	2	28	########	1.00	########	########	2.00	########	########
4								PIPE FITTER	1	14	2	28	########	1.00	########	########	2.00	########	########
5															-	-		-	-
6															-	-		-	-
7															-	-		-	-
8															-	-		-	-
9															-	-		-	-
10															-	-		-	-
11															-	-		-	-
12															-	-		-	-
13															-	-		-	-
14															-	-		-	-
15															-	-		-	-
16															-	-		-	-
17															-	-		-	-
18				TOTAL					3		6		########		########				########
CUTTING OF CORRODED PIPES

Cell Formulas
Range	Formula
L2	L2	=K2*J2*I2
L3:L4	L3	=L2
P2:P17	P2	=O2*L2
R2:R7	R2	=P2*Q2
R8:R17	R8	=P8*2
I18,S18,O18,M18,K18	I18	=SUM(I2:I17)
O2:O4	O2	=N2*M2*I2
O5:O16	O5	=M5*I5
O17	O17	=M17*0.2
S2:S17	S2	=R2

Thanks for your assistance so far.

 

[JLGWhiz]

The #REF! errors occur because the copied formulas lose their source data when copied to different sheet that may not have data in the referenced location of the formula. That being said, here is a modified version of the code which pastes values only. It should only address the odd numbered sheets. I assumed that you were referring to the sheet index numbers rather than the sheets being named "1", "3". "5". etc/ Ot os o,[prtamt tp imderstamd that the computer sees a difference between a 1 and a "1". even thought you can add them and get a 2.

Sub t2()
Dim s As Long, rng As Variant, i As Long
    For s = 1 To Sheets(Sheets.Count) Step 2
        If Sheets(s).Name <> "TRACKER" Then
            With Sheets(s)
                rng = Array(.Range("B2"), .Range("C2"), .Range("D2"), .Range("E2"), .Range("F2"), .Range("I18"), .Range("L2"), .Range("S18"))
                For i = LBound(rng) To UBound(rng)
                    If i = LBound(rng) Then
                        rng(i).Copy
                        Sheets("TRACKER").Cells(Rows.Count, 2).End(xlUp)(2).Offset(, i).PasteSpecial xlPasteValuesAndNumberFormats
                    Else
                        rng(i).Copy
                        Sheets("TRACKER").Cells(Rows.Count, 2).End(xlUp).Offset(, i).PasteSpecial xlPasteVluesAndNumberFormatds
                    End If
                Next
            End With
        End If
    Next
End Sub

 

[ElBillions]

The #REF! errors occur because the copied formulas lose their source data when copied to different sheet that may not have data in the referenced location of the formula. That being said, here is a modified version of the code which pastes values only. It should only address the odd numbered sheets. I assumed that you were referring to the sheet index numbers rather than the sheets being named "1", "3". "5". etc/ Ot os o,[prtamt tp imderstamd that the computer sees a difference between a 1 and a "1". even thought you can add them and get a 2.

Sub t2()
Dim s As Long, rng As Variant, i As Long
    For s = 1 To Sheets(Sheets.Count) Step 2
        If Sheets(s).Name <> "TRACKER" Then
            With Sheets(s)
                rng = Array(.Range("B2"), .Range("C2"), .Range("D2"), .Range("E2"), .Range("F2"), .Range("I18"), .Range("L2"), .Range("S18"))
                For i = LBound(rng) To UBound(rng)
                    If i = LBound(rng) Then
                        rng(i).Copy
                        Sheets("TRACKER").Cells(Rows.Count, 2).End(xlUp)(2).Offset(, i).PasteSpecial xlPasteValuesAndNumberFormats
                    Else
                        rng(i).Copy
                        Sheets("TRACKER").Cells(Rows.Count, 2).End(xlUp).Offset(, i).PasteSpecial xlPasteVluesAndNumberFormatds
                    End If
                Next
            End With
        End If
    Next
End Sub

Thanks Again, JLGWhiz,
i ran the code and it gave me the first error as:

Sub t2()

then i continued and got :

For s = 1 To Sheets(Sheets.Count) Step 2

 

[mohadin]

Should be

For s = 1 To Sheets.Count Step 2

 

[JLGWhiz]

I think I fixed all the typos. It tested OK. Give this version a try.

Sub t3()
Dim s As Long, rng As Variant, i As Long
    For s = 1 To Sheets.Count Step 2
        If Sheets(s).Name <> "TRACKER" Then
            With Sheets(s)
                rng = Array(.Range("B2"), .Range("C2"), .Range("D2"), .Range("E2"), .Range("F2"), .Range("I18"), .Range("L2"), .Range("S18"))
                For i = LBound(rng) To UBound(rng)
                    If i = LBound(rng) Then
                        rng(i).Copy
                        Sheets("TRACKER").Cells(Rows.Count, 2).End(xlUp)(2).Offset(, i).PasteSpecial xlPasteValuesAndNumberFormats
                    Else
                        rng(i).Copy
                        Sheets("TRACKER").Cells(Rows.Count, 2).End(xlUp).Offset(, i).PasteSpecial xlPasteValuesAndNumberFormats
                    End If
                Next
            End With
        End If
    Next
End Sub

 

[ElBillions]

I think I fixed all the typos. It tested OK. Give this version a try.

Sub t3()
Dim s As Long, rng As Variant, i As Long
    For s = 1 To Sheets.Count Step 2
        If Sheets(s).Name <> "TRACKER" Then
            With Sheets(s)
                rng = Array(.Range("B2"), .Range("C2"), .Range("D2"), .Range("E2"), .Range("F2"), .Range("I18"), .Range("L2"), .Range("S18"))
                For i = LBound(rng) To UBound(rng)
                    If i = LBound(rng) Then
                        rng(i).Copy
                        Sheets("TRACKER").Cells(Rows.Count, 2).End(xlUp)(2).Offset(, i).PasteSpecial xlPasteValuesAndNumberFormats
                    Else
                        rng(i).Copy
                        Sheets("TRACKER").Cells(Rows.Count, 2).End(xlUp).Offset(, i).PasteSpecial xlPasteValuesAndNumberFormats
                    End If
                Next
            End With
        End If
    Next
End Sub

Thanks so much JLGWhiz!!!!
It finally worked..
Thanks for all your consistent effort and support.
I dont know if this is proper as per house rules but i also want a code to copy the even numbered ws (Range A1:H25) and save them in MS Word in readiness for printing, at the click of a button.
Each worksheet to a word document.
The above mentioned range is a table with formattings and inserted logos and i want them all to be copied.
Again, thanks so much JLGWhiz!!!!

​