copy from multiple worksheets to single worksheet

[tcarter963]

I have this code that I was trying to modify to loop through then paste to a new worksheet. I can't seem to get the loop to work. It will work on one sheet and that's it. It isn't a must have, but it would really be nice to be able to copy to a new blank worksheet rather than within the same sheet. I'm using excel 2003 and 2007. One more thing that may be pertinent is that I have graphs as sheets present in the same workbook.

Option Explicit

Sub CpAveWS()


Dim WS As Worksheet


For Each WS In ActiveWorkbook.Worksheets
   
Dim LastRowColumnI As Long
Dim LastRowColumnBB As Long

   Application.ScreenUpdating = False
    
    LastRowColumnI = Range("I301").End(xlUp).Row
    
    Range("O2:W" & LastRowColumnI).Copy
    Range("BB2:BJ" & LastRowColumnI).PasteSpecial (xlPasteValues)
        Selection.SpecialCells(xlCellTypeBlanks).Delete (xlShiftUp)
    
    LastRowColumnBB = Range("BB301").End(xlUp).Row
    
    Range("BA2:BA" & LastRowColumnBB).Value = Range("B2").Value
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
        
       On Error Resume Next
    Next WS
    
    
End Sub

 

[AlphaFrog]

You're looping through the sheets but not doing anything with them (WS). You need to reference WS. Your code is just running on the active sheet. Looping through all the sheets doesn't make them active.

Try something like this...

Option Explicit

Sub CpAveWS()

    Dim WS As Worksheet
    Dim LastRow As Long
    
    Application.ScreenUpdating = False
    
    For Each WS In ActiveWorkbook.Worksheets

        LastRow = [COLOR="Red"]WS.[/COLOR]Range("I301").End(xlUp).Row
        
        [COLOR="Red"]WS.[/COLOR]Range("BB2:BJ" & LastRow).Value = [COLOR="Red"]WS.[/COLOR]Range("O2:W" & LastRow).Value
        [COLOR="Red"]WS.[/COLOR]Range("O2:W" & LastRow).SpecialCells(xlCellTypeBlanks).Delete (xlShiftUp)
        
        LastRow = [COLOR="Red"]WS.[/COLOR]Range("BB301").End(xlUp).Row
        [COLOR="Red"]WS.[/COLOR]Range("BA2:BA" & LastRow).Value = [COLOR="Red"]WS.[/COLOR]Range("B2").Value
            
    Next WS
    
    Application.ScreenUpdating = True
    
End Sub

 

[tcarter963]

That seems so simple. Thanks a lot.

I like the last row change as well.

 

[tcarter963]

Thanks again Alpha. I had to modify the code a little bit more to get it to do exactly what I wanted it to do. At least now I know where to start on trying to copy everything to one sheet for a summary table. I needed that information copied on each worksheet as well to remove merged cells.

Here are the changes I made

Sub CpAveWS()


Dim WS As Worksheet

Dim LastRowColumnI As Long
Dim LastRowColumnBB As Long

For Each WS In ActiveWorkbook.Worksheets
   

   Application.ScreenUpdating = False
    
    LastRowColumnI = WS.Range("I301").End(xlUp).Row
        
    WS.Range("BB2:BJ" & LastRowColumnI).Value = WS.Range("O2:W" & LastRowColumnI).Value
    WS.Range("BB2:BJ" & LastRowColumnI).SpecialCells(xlCellTypeBlanks).Delete (xlShiftUp)
    
    LastRowColumnBB = WS.Range("BB301").End(xlUp).Row
    
    WS.Range("BA2:BA" & LastRowColumnBB).Value = WS.Range("B2").Value
    
    Application.CutCopyMode = False
       On Error Resume Next
     
    Next WS
  
  Application.ScreenUpdating = True
    
End Sub