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

ElBillions

New Member
Joined
Feb 15, 2021
Messages
6
Office Version
  1. 2007
Platform
  1. Windows
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.
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
Try this

VBA Code:
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

New Member
Joined
Feb 15, 2021
Messages
6
Office Version
  1. 2007
Platform
  1. Windows
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

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
Which line of code is highlighted when you click the 'Debug' button? Also, do you have any blank sheets in that workbook?
 

ElBillions

New Member
Joined
Feb 15, 2021
Messages
6
Office Version
  1. 2007
Platform
  1. Windows

ADVERTISEMENT

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
BCDEFGHIJKLMNOPQRSTUV
1CSU-3/4/5CRV-041 OUTLET LINE#REF!#REF!#REF!
21-E-1104B RICH/LEAN AMINE EXCHANGER TO REMOVE LEAKING HEAT EXCHANGER AND REPLACE WITH NEWLY REFURBISHED ONE
3692699
4Perforation and corrosion,Damaned gate lock observed om HEAT EXCHANGER AND REPLACE WITH NEWLY REFURBISHED ONE
51-E-1104B RICH/LEAN AMINE EXCHANGER TO REMOVE LEAKING HEAT EXCHANGER AND REPLACE WITH NEWLY REFURBISHED ONE1-E-1104BPMD1-E-1104B RICH/LEAN #REF!#REF!#REF!
6SCRAPPING OF 40FT & 20FT CONTAINER AT THE ADMIN BLOCK
7HEATING, CUTTING AND WELDING IA WORKSHOP FOR 1P-1550/B
8TRAIN 1 GEARBOX FAN HUB HEATING
9FABRICATE AND INSTALL CANOPY AT IA FIRE STATION
10FABRICATE 2 NO ELECTRICAL PANEL COVER FOR SHUTDOWN ARENA
11FABRICATE 2 NO ELECTRICAL PANEL COVER FOR SHUTDOWN ARENA
12FABRICATE 2 UNIT OF TV STAND FOR PMF OFFICE
132/3" CONDENSATE DRAIN HEADER FROM 1-6V-1201 TO UNIT 2000
14FABRICATE AND INSTAL TOWING BAR AT THE AIRSTRIP HILUX FOR LUGGAGE HAULAGE
15FABRICATE 6 NOS TURNDISH FOR TRAIN 1/2/3/4/5/6V-1106 HYDROCARBON SKIM POT
16SCRAP 20 NOS 40FT CONTAINERS AT H-BLOCK
17TRANSFER TOW BAR FROM TRUCK EKY 971 XA TO TRUCK LSD 37 AM
18REPAIR OF CORRODED HANDRAIL AND MESH COVER OF THE ISB/OSB PONTOON
19PRE-FABRICATION OFCORRODED STEM COVER FOR BLOCK VALVE
20FABRICATE 5" & 6" PIPE SPOOLS FOR AKIAMA WATER PLANT.
21
TRACKER
Cell Formulas
RangeFormula
G1,I5,G5,I1G1=SUM(#REF!)
H1,H5H1=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
ABCDEFGHIJKLMNOPQRS
1S/NWORK DESCRIPTION JOB NO.TAG NO.AREAEQUIP. DESCRIPTIONDISCIPLINECATEGORYNOS.HRSDAYSDURATN HRSRATEWEIGHT ON RATECREW RATEAMOUNTSITE FACTOR (SF)AMOUNT BY SFTOTAL
21683569CIV-H3401JETTY 1FAB/WELDERSFAB SUPERVOR114228########0.20684.60########2.00################
3FABRICATOR114228########1.00################2.00################
4PIPE FITTER114228########1.00################2.00################
5----
6----
7----
8----
9----
10----
11----
12----
13----
14----
15----
16----
17----
18TOTAL36########################
CUTTING OF CORRODED PIPES
Cell Formulas
RangeFormula
L2L2=K2*J2*I2
L3:L4L3=L2
P2:P17P2=O2*L2
R2:R7R2=P2*Q2
R8:R17R8=P8*2
I18,S18,O18,M18,K18I18=SUM(I2:I17)
O2:O4O2=N2*M2*I2
O5:O16O5=M5*I5
O17O17=M17*0.2
S2:S17S2=R2


Thanks for your assistance so far.
 

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
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.

VBA Code:
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

New Member
Joined
Feb 15, 2021
Messages
6
Office Version
  1. 2007
Platform
  1. Windows

ADVERTISEMENT

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.

VBA Code:
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

Well-known Member
Joined
Mar 22, 2015
Messages
1,091
Office Version
  1. 2013
Platform
  1. Windows
Should be
VBA Code:
For s = 1 To Sheets.Count Step 2
 

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
I think I fixed all the typos. It tested OK. Give this version a try.

VBA Code:
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
 
Solution

ElBillions

New Member
Joined
Feb 15, 2021
Messages
6
Office Version
  1. 2007
Platform
  1. Windows
I think I fixed all the typos. It tested OK. Give this version a try.

VBA Code:
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.(y).
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!!!!

 

Watch MrExcel Video

Forum statistics

Threads
1,130,422
Messages
5,642,021
Members
417,250
Latest member
spr1nger

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top