Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Code For Copy Copies Twice
Hi,
Thanks to all who have helped with code for my workbook, I have managed to piece it all together to perform several task with the click of a button, but have two small glitches I hope someone can help resolve. The last bit of code " 'copy summary from main worksheet" should copy w1:am75 and place in same location on each of the worksheets listed. It will do this but also copies w34:am75 and places it underneath the first copy of w1:am75. The second portion that is copied has lines inserted at each place a total line is inserted from code listed above. I tried several ways of rearranging the code thinking it was something in the looping process and nothing seems to correct it. If anyone can please take a look and tell me what is going wrong with this and possibly clean up code as needed, I would really appreciate the assistance. Also, how do I make the highlight for the total rows that are found in cols B & C extend left to A & B. I would like for it to cover the section A:P, but this is the only code I could find that would work. Sub Total_Bookings_WorksheetsTest2() Dim ws As Worksheet Dim rng As Range For Each ws In Worksheets Select Case ws.Name 'All sheet names listed in the case statement 'will be processed. Change the names I have 'used to your sheet names and add your 'additional sheet names separated by commas. Case "Bk01-09", "Bk02-09" ws.Select 'Sort selected worksheets Range("A1:p900").Select Selection.Sort Key1:=Range("c2"), _ Order1:=xlAscending, _ Key2:=Range("A2"), Order2:=xlAscending, _ Key2:=Range("b2"), Order2:=xlAscending, _ Header:=xlYes On Error Resume Next 'Following line references active sheet so 'do not nest inside the With/End With Set rng = Range(Range("j2"), _ Cells(2, Columns.Count).End(xlToLeft)) On Error GoTo 0 If Not rng Is Nothing Then With ws 'Subtotal selected sheets .Range("j2").Subtotal _ GroupBy:=3, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True .Range("j2").Subtotal _ GroupBy:=1, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True .Range("j2").Subtotal _ GroupBy:=2, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True 'Format area for summary formulas from main sheet .Range("w2:am75").NumberFormat = "$#,##0.00;($#,##0.00)" .Range("w2:am75").Font.Size = 8 End With End If 'Bold and insert row at "total" rows Dim LastRow As Long Dim r As Long 'Following code references active sheet so 'do not nest inside the With/End With LastRow = Range("G" & Rows.Count).End(xlUp).Row For r = LastRow To 2 Step -1 If InStr(1, Cells(r, 1).Value, "Total") 0 Or _ InStr(1, Cells(r, 2).Value, "Total") 0 Or _ InStr(1, Cells(r, 3).Value, "Total") 0 Or _ InStr(1, Cells(r, 4).Value, "Total") 0 Then Range(Cells(r, 1), Cells(r, 16)).Font.Bold = True ActiveSheet.Rows(r + 1).EntireRow.Insert End If Next 'Highlight "total" rows Dim rngFound As Range Dim strFirstAddress As String 'Search slsp (Col A) for Total rows & highlight Set rngFound = Columns("A").Find(What:="total", _ LookAt:=xlPart, _ LookIn:=xlValues, _ MatchCase:=False) If Not rngFound Is Nothing Then strFirstAddress = rngFound.Address Do rngFound.Resize(, 16).Interior.ColorIndex = 17 Set rngFound = Columns("A").FindNext(rngFound) Loop Until rngFound.Address = strFirstAddress End If 'Search Class (Col B) for Total rows & highlight Set rngFound = Columns("B").Find(What:="total", _ LookAt:=xlPart, _ LookIn:=xlValues, _ MatchCase:=False) If Not rngFound Is Nothing Then strFirstAddress = rngFound.Address Do rngFound.Resize(, 15).Interior.ColorIndex = 6 Set rngFound = Columns("B").FindNext(rngFound) Loop Until rngFound.Address = strFirstAddress End If 'Search Dept (Col C) for Total rows & highlight Set rngFound = Columns("c").Find(What:="total", _ LookAt:=xlPart, _ LookIn:=xlValues, _ MatchCase:=False) If Not rngFound Is Nothing Then strFirstAddress = rngFound.Address Do rngFound.Resize(, 14).Interior.ColorIndex = 23 Set rngFound = Columns("c").FindNext(rngFound) Loop Until rngFound.Address = strFirstAddress End If End Select 'End of Case 'copy summary section from main worksheet Dim wsrng As Range Dim myarray() Dim i As Long Set wsrng = Worksheets("Bookings").Range("w1:AM75") myarray = Array("Bk01-09", "Bk02-09") For i = LBound(myarray) To UBound(myarray) Worksheets(myarray(i)).Range("w1:AM75").Formula = wsrng.Formula 'replace formula with .value if you want to copy cell values Next Next ws End Sub Again, I would really appreciate the help. Thanks in advance, Phisaw |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Code For Copy Copies Twice
Can you put a STOP at the top of this section and see if the last section of code is causing the problem or the problem is occuring before this point. If so can you keep putting the stop in different loications until you find which section of the code is causing the problem. 'add stop here Stop 'copy summary section from main worksheet Dim wsrng As Range Dim myarray() Dim i As Long Set wsrng = Worksheets("Bookings").Range("w1:AM75") myarray = Array("Bk01-09", "Bk02-09") For i = LBound(myarray) To UBound(myarray) Worksheets(myarray(i)).Range("w1:AM75").Formula = wsrng.Formula 'replace formula with .value if you want to copy cell values Next Next ws End Sub -- joel ------------------------------------------------------------------------ joel's Profile: http://www.thecodecage.com/forumz/member.php?userid=229 View this thread: http://www.thecodecage.com/forumz/sh...d.php?t=146642 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Code For Copy Copies Twice
There must be some stray code out there somewhere, or my eyes are worse than
I thought. The code you posted does not refer to the second set of data that you said it is pasting below the desired range. The way to find out for sure what is happening is to step through the code by using the F8 function key. Open the VBE and place the insertion point (cursor) within the procedure code somewhere. Then press F8 to start the code execution, the yellow highlight will show you which line is next to execute. If you diminishe the size of the VBE screed and manually size it you can position it over the worksheets so that you can see when changes in the data occur as you step through. Notice the title bar at the top left and it will display the active sheets. Also, the Project window in the VBE will indicate which module, shee4t or form is executing code by shadowing that object. You should be able to isolate the problem with this debugging technique. "PHisaw" wrote in message ... Hi, Thanks to all who have helped with code for my workbook, I have managed to piece it all together to perform several task with the click of a button, but have two small glitches I hope someone can help resolve. The last bit of code " 'copy summary from main worksheet" should copy w1:am75 and place in same location on each of the worksheets listed. It will do this but also copies w34:am75 and places it underneath the first copy of w1:am75. The second portion that is copied has lines inserted at each place a total line is inserted from code listed above. I tried several ways of rearranging the code thinking it was something in the looping process and nothing seems to correct it. If anyone can please take a look and tell me what is going wrong with this and possibly clean up code as needed, I would really appreciate the assistance. Also, how do I make the highlight for the total rows that are found in cols B & C extend left to A & B. I would like for it to cover the section A:P, but this is the only code I could find that would work. Sub Total_Bookings_WorksheetsTest2() Dim ws As Worksheet Dim rng As Range For Each ws In Worksheets Select Case ws.Name 'All sheet names listed in the case statement 'will be processed. Change the names I have 'used to your sheet names and add your 'additional sheet names separated by commas. Case "Bk01-09", "Bk02-09" ws.Select 'Sort selected worksheets Range("A1:p900").Select Selection.Sort Key1:=Range("c2"), _ Order1:=xlAscending, _ Key2:=Range("A2"), Order2:=xlAscending, _ Key2:=Range("b2"), Order2:=xlAscending, _ Header:=xlYes On Error Resume Next 'Following line references active sheet so 'do not nest inside the With/End With Set rng = Range(Range("j2"), _ Cells(2, Columns.Count).End(xlToLeft)) On Error GoTo 0 If Not rng Is Nothing Then With ws 'Subtotal selected sheets .Range("j2").Subtotal _ GroupBy:=3, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True .Range("j2").Subtotal _ GroupBy:=1, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True .Range("j2").Subtotal _ GroupBy:=2, _ Function:=xlSum, _ TotalList:=Array(10, 11, 12), _ Replace:=False, _ PageBreaks:=False, _ SummaryBelowData:=True 'Format area for summary formulas from main sheet .Range("w2:am75").NumberFormat = "$#,##0.00;($#,##0.00)" .Range("w2:am75").Font.Size = 8 End With End If 'Bold and insert row at "total" rows Dim LastRow As Long Dim r As Long 'Following code references active sheet so 'do not nest inside the With/End With LastRow = Range("G" & Rows.Count).End(xlUp).Row For r = LastRow To 2 Step -1 If InStr(1, Cells(r, 1).Value, "Total") 0 Or _ InStr(1, Cells(r, 2).Value, "Total") 0 Or _ InStr(1, Cells(r, 3).Value, "Total") 0 Or _ InStr(1, Cells(r, 4).Value, "Total") 0 Then Range(Cells(r, 1), Cells(r, 16)).Font.Bold = True ActiveSheet.Rows(r + 1).EntireRow.Insert End If Next 'Highlight "total" rows Dim rngFound As Range Dim strFirstAddress As String 'Search slsp (Col A) for Total rows & highlight Set rngFound = Columns("A").Find(What:="total", _ LookAt:=xlPart, _ LookIn:=xlValues, _ MatchCase:=False) If Not rngFound Is Nothing Then strFirstAddress = rngFound.Address Do rngFound.Resize(, 16).Interior.ColorIndex = 17 Set rngFound = Columns("A").FindNext(rngFound) Loop Until rngFound.Address = strFirstAddress End If 'Search Class (Col B) for Total rows & highlight Set rngFound = Columns("B").Find(What:="total", _ LookAt:=xlPart, _ LookIn:=xlValues, _ MatchCase:=False) If Not rngFound Is Nothing Then strFirstAddress = rngFound.Address Do rngFound.Resize(, 15).Interior.ColorIndex = 6 Set rngFound = Columns("B").FindNext(rngFound) Loop Until rngFound.Address = strFirstAddress End If 'Search Dept (Col C) for Total rows & highlight Set rngFound = Columns("c").Find(What:="total", _ LookAt:=xlPart, _ LookIn:=xlValues, _ MatchCase:=False) If Not rngFound Is Nothing Then strFirstAddress = rngFound.Address Do rngFound.Resize(, 14).Interior.ColorIndex = 23 Set rngFound = Columns("c").FindNext(rngFound) Loop Until rngFound.Address = strFirstAddress End If End Select 'End of Case 'copy summary section from main worksheet Dim wsrng As Range Dim myarray() Dim i As Long Set wsrng = Worksheets("Bookings").Range("w1:AM75") myarray = Array("Bk01-09", "Bk02-09") For i = LBound(myarray) To UBound(myarray) Worksheets(myarray(i)).Range("w1:AM75").Formula = wsrng.Formula 'replace formula with .value if you want to copy cell values Next Next ws End Sub Again, I would really appreciate the help. Thanks in advance, Phisaw |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Save copy on Open, keeping old backup copies | Excel Discussion (Misc queries) | |||
Copy and Paste in Excel, copies cell and formula, but shows same v | Excel Discussion (Misc queries) | |||
Code that searches a column, then copies and pastes any matches intoa new Spreadsheet | Excel Programming | |||
Copy Method of Sheets Class Failed - after many copies | Excel Programming | |||
Trying to eliminate multiple copies of the SAME code within a UserForm | Excel Programming |