Send your code and workbook and all info to:


"David" wrote:

I've created a new workbook using code from another workbook that copied one
datapoint to one page...for 17 pages or so (Each page had it's own
datapoint). The new workbook as all datapoints on one page. I need to copy
those datapoints from 30 sheets in one workbook to 30 sheets in the other
workbook. The source workbook is a weekly file that I am copying the weekly
totals from. The summary workbook has a column for each week ending date. I
test for the column dates to determine which column the data goes into. The
rows and pages are fixed. (In the prior code, it also tested for the row, the
pages were fixed).
I redid the code for the first page and it does exactly what I want, but I
now have to duplicate the code 29 more times and make the associated sheet
changes to obtain and write the data for all 30 sheets.

Is there any way to improve the current code that I've redone for sheet one
to have it do the same thing to the other 29 sheets?

Note: In the source workbook, I have a macro that lets the user set the
number of technicians, i.e., they can have a maximum of 30, but they may only
have 12. The number of technician sheets shown is then set to 12. Ideally, I
would like to have this macro read the number of technicians (which is
displayed on the "Global Settings" page, range ("F5") of the source workbook
and run the same code in this workbook to set the number of technician pages
to the same value and display only those pages (would always be 1 to x). And
then maybe the code would only go up to the amount of technician pages as
well.

Here is the code I have:

Sub CapturePlumberData()
Dim wbSum As Workbook, wbData As Workbook
Set wbSum = Workbooks("2006 Consolidated Plumber File.xls")
Set wbData = ActiveWorkbook

' get source data from open sheet
Dim iOffice As Integer, iDate As Date, iValue

'First Sheet - Need to do this for all 30 sheets
With wbData.Sheets(4)
'Don't need the ioffice Range
iOffice = .Range("J6")
iDate = .Range("C11")
With wbData.Sheets(4)
iValueSG = .Range("J15")
iValueAS = .Range("J16")
iValueV = .Range("J17")
iValueCR = .Range("J18")
iValueCC = .Range("J19")
iValueCRate = .Range("J20")
iValueAVGS = .Range("J21")
iValueRHW = .Range("J22")
iValueOHW = .Range("J23")
iValueLWP = .Range("J24")
iValueWPPS = .Range("J25")
ivalueRV = .Range("J26")
iValueBFSS = .Range("J27")
iValueBMV = .Range("J28")
iValueBIO = .Range("J29")
iValueRW = .Range("H33")
iValueOW = .Range("H34")
iValueBN = .Range("J31")
iValueSP = .Range("J32")
iValueTB = .Range("J33")
iValueTH = .Range("J34")
iValueTAW = .Range("J35")
iValueTWPPS = .Range("J36")

End With

' Set Px Sheets and apply all values

' apply iValueSG - Sales Goal to matched row and column
With wbSum.Sheets(2)
Dim lastrow As Long, lastcol As Long, xV As Long, xR As Long, xC As Long
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
''get matching row
'For xV = 1 To lastrow
'If iOffice = .Cells(xV, 1) Then xR = xV
'Next xV
'If xR = 0 Then MsgBox "Office: " & iOffice & " not found in summary
Table"

' set row manually
xR = 2
' get matching column
For xV = 1 To lastcol
If iDate = .Cells(1, xV) Then xC = xV
Next xV
If xC = 0 Then MsgBox "Date: " & iDate & " not found in summary table"
If xR 0 And xC 0 Then .Cells(xR, xC) = iValueSG
End With

' apply iValueAS - Actual Sales to matched row and column
With wbSum.Sheets(2)
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
''get matching row
'For xV = 1 To lastrow
'If iOffice = .Cells(xV, 1) Then xR = xV
'Next xV
'If xR = 0 Then MsgBox "Office: " & iOffice & " not found in summary
Table"

' set row manually
xR = 3

' get matching column
For xV = 1 To lastcol
If iDate = .Cells(1, xV) Then xC = xV
Next xV
If xC = 0 Then MsgBox "Date: " & iDate & " not found in summary table"
If xR 0 And xC 0 Then .Cells(xR, xC) = iValueAS
End With

' apply iValueV - Sales Variance to matched row and column
With wbSum.Sheets(2)
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column

''get matching row
'For xV = 1 To lastrow
'If iOffice = .Cells(xV, 1) Then xR = xV
'Next xV
'If xR = 0 Then MsgBox "Office: " & iOffice & " not found in summary
Table"

' set row manually
xR = 4

' get matching column
For xV = 1 To lastcol
If iDate = .Cells(1, xV) Then xC = xV
Next xV
If xC = 0 Then MsgBox "Date: " & iDate & " not found in summary table"
If xR 0 And xC 0 Then .Cells(xR, xC) = iValueV
End With

' apply iValueCR - Calls Run to matched row and column
With wbSum.Sheets(2)
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
''get matching row
'For xV = 1 To lastrow
'If iOffice = .Cells(xV, 1) Then xR = xV
'Next xV
'If xR = 0 Then MsgBox "Office: " & iOffice & " not found in summary
Table"

' set row manually
xR = 5

' get matching column
For xV = 1 To lastcol
If iDate = .Cells(1, xV) Then xC = xV
Next xV
If xC = 0 Then MsgBox "Date: " & iDate & " not found in summary table"
If xR 0 And xC 0 Then .Cells(xR, xC) = iValueCR
End With

' apply iValueCC - Calls Closed to matched row and column
With wbSum.Sheets(2)
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
''get matching row
'For xV = 1 To lastrow
'If iOffice = .Cells(xV, 1) Then xR = xV
'Next xV
'If xR = 0 Then MsgBox "Office: " & iOffice & " not found in summary
Table"

' set row manually
xR = 6

' get matching column
For xV = 1 To lastcol
If iDate = .Cells(1, xV) Then xC = xV
Next xV
If xC = 0 Then MsgBox "Date: " & iDate & " not found in summary table"
If xR 0 And xC 0 Then .Cells(xR, xC) = iValueCC
End With

' apply iValueCRate - Calls Closed Rate to matched row and column
With wbSum.Sheets(2)
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
''get matching row
'For xV = 1 To lastrow
'If iOffice = .Cells(xV, 1) Then xR = xV
'Next xV
'If xR = 0 Then MsgBox "Office: " & iOffice & " not found in summary
Table"

' set row manually
xR = 7

' get matching column
For xV = 1 To lastcol
If iDate = .Cells(1, xV) Then xC = xV
Next xV
If xC = 0 Then MsgBox "Date: " & iDate & " not found in summary table"
If xR 0 And xC 0 Then .Cells(xR, xC) = iValueCRate
End With

' apply iValueAVGS - Average Sale to matched row and column
With wbSum.Sheets(2)
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
''get matching row
'For xV = 1 To lastrow
'If iOffice = .Cells(xV, 1) Then xR = xV
'Next xV
'If xR = 0 Then MsgBox "Office: " & iOffice & " not found in summary
Table"

' set row manually
xR = 8

' get matching column
For xV = 1 To lastcol
If iDate = .Cells(1, xV) Then xC = xV
Next xV
If xC = 0 Then MsgBox "Date: " & iDate & " not found in summary table"
If xR 0 And xC 0 Then .Cells(xR, xC) = iValueAVGS
End With

' apply iValueRHW - Regular Hours Worked to matched row and column
With wbSum.Sheets(2)
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
''get matching row
'For xV = 1 To lastrow
'If iOffice = .Cells(xV, 1) Then xR = xV
'Next xV
'If xR = 0 Then MsgBox "Office: " & iOffice & " not found in summary
Table"

' set row manually
xR = 9

' get matching column
For xV = 1 To lastcol
If iDate = .Cells(1, xV) Then xC = xV
Next xV
If xC = 0 Then MsgBox "Date: " & iDate & " not found in summary table"
If xR 0 And xC 0 Then .Cells(xR, xC) = iValueRHW
End With

' apply iValueOHW - OverTime Hours Worked to matched row and column
With wbSum.Sheets(2)
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
''get matching row
'For xV = 1 To lastrow
'If iOffice = .Cells(xV, 1) Then xR = xV
'Next xV
'If xR = 0 Then MsgBox "Office: " & iOffice & " not found in summary
Table"

' set row manually
xR = 10

' get matching column
For xV = 1 To lastcol
If iDate = .Cells(1, xV) Then xC = xV
Next xV
If xC = 0 Then MsgBox "Date: " & iDate & " not found in summary table"
If xR 0 And xC 0 Then .Cells(xR, xC) = iValueOHW
End With

' apply iValueLWP - Labor Wages Paid to matched row and column
With wbSum.Sheets(2)
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
''get matching row
'For xV = 1 To lastrow
'If iOffice = .Cells(xV, 1) Then xR = xV
'Next xV
'If xR = 0 Then MsgBox "Office: " & iOffice & " not found in summary
Table"

' set row manually
xR = 11

' get matching column
For xV = 1 To lastcol
If iDate = .Cells(1, xV) Then xC = xV
Next xV
If xC = 0 Then MsgBox "Date: " & iDate & " not found in summary table"
If xR 0 And xC 0 Then .Cells(xR, xC) = iValueLWP
End With

' apply iValueWPPS - Wages Paid as Percent of Sales to matched row and column
With wbSum.Sheets(2)
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
lastcol = .Cells(1, Columns.Count).End(xlToLeft).Column
''get matching row
'For xV = 1 To lastrow
'If iOffice = .Cells(xV, 1) Then xR = xV
'Next xV
'If xR = 0 Then MsgBox "Office: " & iOffice & " not found in summary