Copy Paste Data from every sheet to Another Workbook with sheet name using VBA

[ashish002]

Hi All,

I am looking to copy paste a data (Range W2:BB1000) from each sheet to a new workbook along with sheet names from the source workbook.

Eg: If Book1.xlsx has 3 worksheets -> US, UK, CA then the code should copy the range as mentioned above in each worksheet and paste in to new workbook Book2.xlsx along with sheet name.

Any help would be appreciated.

Thanks

 

[igold]

How about this:

Sub CopySheets()

    Dim wb As Workbook, nam As String, i As Long
    Dim twb As Workbook: Set twb = ThisWorkbook
    Dim ws As Object: Set ws = Worksheets
    
    Application.ScreenUpdating = False
    nam = twb.Name
    Set wb = Workbooks.Add
    twb.Activate
    For i = 1 To ws.Count
        ws(i).Range("W2:BB1000").Copy wb.ActiveSheet.Range("W2")
        wb.ActiveSheet.Name = ws(i).Name
        If i = ws.Count Then
            twb.Activate
            Application.ScreenUpdating = True
            MsgBox "Operation Complete"
            Exit Sub
        End If
        wb.ActiveSheet.Next.Activate
    Next
    MsgBox "Operation Complete"
    Application.ScreenUpdating = True
    
End Sub

 

[ashish002]

I tried this, getting runtime error 91: "Object variable or With block variable not set".

 

[Alex Blakenburg]

Don't you have a pivot table at that location in the sheet ?
(ref: https://www.mrexcel.com/board/threads/unable-to-get-the-pivotfields-property-of-the-pivottable-class.1217757/)
Are you copying the pivot table as values only ?
Are you only copying the pivot table or is there other data in that range ?

 

[ashish002]

There is table starting from range A1 to Q30000 and then pivot tables starting from W2 to BB1000. I am looking to copy only the pivot table as values from each sheet. The code does copies one sheet perfectly but it is unable to do so for other sheets.

 

[Alex Blakenburg]

I assume you want the pivot posted to A1 or A2 in the new workbook don't you ?

 

[ashish002]

I assume you want the pivot posted to A1 or A2 in the new workbook don't you ?

Yes, that's correct

 

[Alex Blakenburg]

Try this:
PS: Not giving any indication that you are trying to copy a pivot and that you are only want values is not giving you much of chance of getting what you need.

Sub CopyPvtValues()

    Dim destWB As Workbook, destWS As Worksheet, i As Long, sFirstSht As String
    Dim thisWB As Workbook
    Dim thisWS As Worksheet
    Dim pvtRng As Range
    Dim pvtTotalOffset As Long
    
    Application.ScreenUpdating = False

    Set thisWB = ThisWorkbook
    Set destWB = Workbooks.Add(Template:=xlWBATWorksheet)
    sFirstSht = "Y"

    For i = 1 To thisWB.Worksheets.Count
        Set thisWS = thisWB.Worksheets(i)
        
        On Error Resume Next
        Set pvtRng = thisWS.Range("W2").Offset(2).PivotTable.TableRange2
        
        If Err = 0 Then                                 ' if pivot exists at nominated location then copy
            On Error GoTo 0
            If sFirstSht = "Y" Then
               Set destWS = destWB.Worksheets(1)        ' Use existing sheet
               sFirstSht = "N"
            Else
                Set destWS = destWB.Worksheets.Add(after:=destWB.Worksheets(destWB.Worksheets.Count))
            End If

            ' Copying Pivot Values and Format, requires the pivot to be copied in 2 pieces
            pvtRng.Resize(pvtRng.Rows.Count - 1).Copy
            destWB.ActiveSheet.Range("A2").PasteSpecial Paste:=xlPasteValues
            destWB.ActiveSheet.Range("A2").PasteSpecial Paste:=xlPasteFormats
            destWB.ActiveSheet.Range("A2").PasteSpecial Paste:=xlPasteColumnWidths
    
            pvtTotalOffset = pvtRng.Rows.Count - 1
            pvtRng.Offset(pvtTotalOffset).Resize(1).Copy
            destWB.ActiveSheet.Range("A2").Offset(pvtTotalOffset).PasteSpecial Paste:=xlPasteValues
            destWB.ActiveSheet.Range("A2").Offset(pvtTotalOffset).PasteSpecial Paste:=xlPasteFormats
            
            destWS.Name = thisWS.Name
        Else
            On Error GoTo 0
        End If

    Next
    
    thisWB.Activate
  
    MsgBox "Operation Complete"
    Application.ScreenUpdating = True
    
End Sub

 

[ashish002]

Try this:
PS: Not giving any indication that you are trying to copy a pivot and that you are only want values is not giving you much of chance of getting what you need.

Sub CopyPvtValues()

    Dim destWB As Workbook, destWS As Worksheet, i As Long, sFirstSht As String
    Dim thisWB As Workbook
    Dim thisWS As Worksheet
    Dim pvtRng As Range
    Dim pvtTotalOffset As Long
   
    Application.ScreenUpdating = False

    Set thisWB = ThisWorkbook
    Set destWB = Workbooks.Add(Template:=xlWBATWorksheet)
    sFirstSht = "Y"

    For i = 1 To thisWB.Worksheets.Count
        Set thisWS = thisWB.Worksheets(i)
       
        On Error Resume Next
        Set pvtRng = thisWS.Range("W2").Offset(2).PivotTable.TableRange2
       
        If Err = 0 Then                                 ' if pivot exists at nominated location then copy
            On Error GoTo 0
            If sFirstSht = "Y" Then
               Set destWS = destWB.Worksheets(1)        ' Use existing sheet
               sFirstSht = "N"
            Else
                Set destWS = destWB.Worksheets.Add(after:=destWB.Worksheets(destWB.Worksheets.Count))
            End If

            ' Copying Pivot Values and Format, requires the pivot to be copied in 2 pieces
            pvtRng.Resize(pvtRng.Rows.Count - 1).Copy
            destWB.ActiveSheet.Range("A2").PasteSpecial Paste:=xlPasteValues
            destWB.ActiveSheet.Range("A2").PasteSpecial Paste:=xlPasteFormats
            destWB.ActiveSheet.Range("A2").PasteSpecial Paste:=xlPasteColumnWidths
   
            pvtTotalOffset = pvtRng.Rows.Count - 1
            pvtRng.Offset(pvtTotalOffset).Resize(1).Copy
            destWB.ActiveSheet.Range("A2").Offset(pvtTotalOffset).PasteSpecial Paste:=xlPasteValues
            destWB.ActiveSheet.Range("A2").Offset(pvtTotalOffset).PasteSpecial Paste:=xlPasteFormats
           
            destWS.Name = thisWS.Name
        Else
            On Error GoTo 0
        End If

    Next
   
    thisWB.Activate
 
    MsgBox "Operation Complete"
    Application.ScreenUpdating = True
   
End Sub

Superb!!!. This worked like a charm and apologies for not mentioning about pivot.
Thanks again for all your time and efforts. My project is finally finished.

 

[Alex Blakenburg]

You're welcome. Glad we could help.