Home |
Search |
Today's Posts |
#1
![]()
Posted to microsoft.public.excel.misc
|
|||
|
|||
![]()
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 Table" ' set row manually xR = 12 ' 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) = iValueWPPS End With ' apply iValueRV - Return Visits 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 = 13 ' 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) = ivalueRV End With ' apply iValueBFSS - Ben Franklin Society's Sold 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 = 14 ' 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) = iValueBFSS End With ' apply iValueBMV - BFS Maintenance Visits 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 = 15 ' 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) = iValueBMV End With ' apply iValueBIO - Bio Smarts Sold 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 = 16 ' 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) = iValueBIO End With ' apply iValueRW - Regular Wages 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 = 17 ' 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) = iValueRW End With ' apply iValueOW - OverTime Hours 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 = 18 ' 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) = iValueOW End With ' apply iValueBN - Bonuses 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 = 19 ' 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) = iValueBN End With ' apply iValueSP - Spiffs 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 = 20 ' 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) = iValueSP End With ' apply iValueTB - Total Bonuses 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 = 21 ' 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) = iValueTB End With ' apply iValueTH - Total Hours 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 = 22 ' 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) = iValueTH End With ' apply iValueTAW - Total All Wages 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 = 23 ' 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) = iValueTAW End With ' apply iValueTWPPS - Total Wages Paid 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 Table" ' set row manually xR = 24 ' 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) = iValueTWPPS End With ' END OF FIRST SHEET - NEED TO IMPROVE CODE ABOVE - REPEAT 29 TIMES :( '****Put this back when finished with code**** ''Save the file 'With wbSum '.Save 'End With ''Minimize Master BP Graph Workbook 'With wbSum 'WindowState = xlMinimized '' Application.WindowState = xlNormal 'End With ''Save BP File to Franchise Directory 'With wbData 'Dim fname As String 'With ActiveWorkbook.Worksheets(2) 'fname = .Range("B4").Value & Format(.Range("F6").Value, " mm dd yyyy") & ".xls" '****End of Put this back**** '****For Network Drive Path - Put Back!!***** 'ChDrive "F:" 'ChDir "F:\Franchise_GPC\Ben Franklin Info\Ben Franchises\2006 Big Picture\" '.SaveAs "F:\Franchise_GPC\Ben Franklin Info\Ben Franchises\2006 Big Picture\" & fname '****Put this back for local testing when finished with coding**** ''****FileName for Testing Only - Take Out and Put Back Above for Work***** '.SaveAs fname 'End With 'With wbData 'ActiveWorkbook.Close 'End With ''Minimize Master BP Graph Workbook Again 'With wbSum 'Application.WindowState = xlMinimized 'End With '****End of Put this back**** End With End Sub |
#2
![]()
Posted to microsoft.public.excel.misc
|
|||
|
|||
![]() |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
![]() |
||||
Thread | Forum | |||
Links auto update on some workbooks but not others | Excel Worksheet Functions | |||
VLOOKUP for Zip Code Ranges | Excel Worksheet Functions | |||
Concatinate a filename | Excel Discussion (Misc queries) | |||
Often-Used Code not working in a new Workbook | Excel Discussion (Misc queries) | |||
Workbooks...I'll try this again... | Excel Discussion (Misc queries) |