asked on

Copying Multiple Sheets To New Worksheet Without VBA Codes, UserForm, Formula or Pictures

Hi All,

I have a worksheet to process payment, once Batch Control Slip sheet is updated, below vba updates all other sheets:

Sub PaymentProcess()

Dim wsA As Worksheet, wsB As Worksheet, wsC As Worksheet, wsD As Worksheet
Dim LastRow As Long, i As Long, j As Long
Dim LR As Long
Dim str As String

Set wsA = Sheets("Batch Control Slip")
Set wsB = Sheets("Coding Template")
Set wsC = Sheets("INVOICES")
Set wsD = Sheets("Fax-Transmittal")

LastRow = wsA.Range("I" & Rows.Count).End(xlUp).Row
str = wsA.Range("B19").CurrentRegion.Address

LR = wsC.Range("E65536").End(xlUp).Row
    If LastRow > 1 Then
        With wsC.Range("A2:E" & LastRow)
            .Cells(.Rows.Count, "A").End(xlUp).Font.Bold = False
            .Cells(.Rows.Count, "B").End(xlUp).Font.Bold = False
            .Cells(.Rows.Count, "D").End(xlUp).Font.Bold = False
            .ClearContents
        End With
    End If
    
'Select values to copy from "Batch Control Slip" Sheet
wsA.Select
Columns("B:M").EntireColumn.AutoFit
Range("B20:M" & LastRow).Copy

'Paste onto "Coding Template" Sheet
wsB.Select
Range("A2").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
wsB.Columns("A:L").EntireColumn.AutoFit
Application.CutCopyMode = False
Range("A2").Select

'Paste onto "Invoices" Sheet
wsA.Select
Range("H20:H" & LastRow).Copy
wsC.Select
Range("A2").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
wsA.Select
Range("F20:F" & LastRow).Copy
wsC.Select
Range("B2").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
wsA.Select
Range("I20:I" & LastRow).Copy
wsC.Select
Range("E2").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
wsC.Range("C2:C" & LR).Formula = "=IF(RIGHT('Batch Control Slip'!R[18]C[4],3)=""USD"","""",IF(RC[-1]<>0,ROUND('Batch Control Slip'!R18C7,4),""""))"
wsC.Range("C2:C" & LR).Copy
wsC.Range("C2:C" & LR).PasteSpecial xlValues
wsC.Range("D2:D" & LR).Formula = "=IF(RC[-1]="""",RC[-2],(RC[-2]*RC[-1]))"
wsC.Range("D2:D" & LR).Copy
wsC.Range("D2:D" & LR).PasteSpecial xlValues
wsC.Range("A" & LR + 2) = "Total"
    wsC.Range("A" & LR + 2).Font.Bold = True
wsC.Range("B" & LR + 2).Formula = "=SUBTOTAL(9,B2:B" & LR & ")"
    wsC.Range("B" & LR + 2).Font.Bold = True
wsC.Range("D" & LR + 2).Formula = "=SUBTOTAL(9,D2:D" & LR & ")"
    wsC.Range("D" & LR + 2).Font.Bold = True
wsC.Columns("A:E").EntireColumn.AutoFit
Range("A2").Select

' Add Value Date for Fax-Transmittal sheet
wsD.Select
MsgBox "Select Today's Date", vbInformation, "Show Calendar"
wsD.Range("B7").Select
MsgBox "Select Value Date As Coming Friday", vbInformation, "Show Calendar"
wsD.Range("C42").Select
Range("A3").Select
Call CopySheets
End Sub

Open in new window

Then to create a copy I use below code:

Sub CopySheets()
Dim bk As Workbook, sh As Worksheet
 
    ThisWorkbook.Sheets.Copy
    
    Set bk = ActiveWorkbook
    
    For Each sh In bk.Worksheets
        sh.Cells.Copy
        sh.Cells.PasteSpecial xlValues
    Next
    
End Sub

Open in new window

My Problems/failure:

1. Which copies all the worksheet, I need to specify only few sheets.
2. It copies Picture & private sub for one worksheet, which is not in module.
3. I have spellnumber function in Payment Process worksheet, which doesn't copy, it pastes error "#NAME?".
4. After/or before this process I need to save as new worksheet with Range reference in "Batch Control Slip" Sheets.

Kindly help........

Norie

1 Which worksheets do you want to copy?

2 Which worksheet is this?

3 You'll need to do a copy and paste special in the original workbook where the SpellNumber function is.

4 Which cell/range has the new filename?

Shums Faruk

ASKER

Hi Imnorie,

Thanks for your prompt attention.

I would like to copy wsA = Sheets("Batch Control Slip"), wsB = Sheets("Coding Template") wsC = Sheets("INVOICES") & wsD = Sheets("Fax-Transmittal") to new workbook.

In Sheets("Fax-Transmittal") is calendar userform which pops up as I click cells with specified format. Which copies along with in new workbook.

I can't copy and paste special in original workbook where the spellnumber is because that would be my Payment Process workbook for all the vendors.

In Sheets("Batch Control Slip").Range("C10") must be the name for new workbook.

Hope all is well.

Norie

I misphrased that, I meant copy from the original workbook and paste special in the new workbook.

You could actually do that for all the sheets being copied but it's needed for the one that uses the SpellNumber function.

Which worksheet is it that uses that function?

You said earlier it was the Payment Process worksheet, but there isn't a worksheet called that in the list of worksheets you want to copy.

Or perhaps I've misread and SpellNumber is used throughout the workbook?

Shums Faruk

ASKER

Sorry I misphrased that, Payment Process is Workbook not worksheet.

Sheets("Fax-Transmittal") uses SpellNumber.

Norie

Try this.

Sub CopyWSToNewWB()
Dim wbNew As Workbook
Dim wsNew As Worksheet
Dim wsSrc As Worksheet
Dim strNewFileName As String

    Set wbNew = Workbooks.Add(xlWBATWorksheet)

    Set wsNew = wbNew.Worksheets(1)

    For Each wsSrc In ThisWorkbook.Worksheets(Array("Batch Control Template", "Coding Template", "INVOICES", "Fax-Transmittal"))

        wsSrc.Cells.Copy

        wsNew.Range("A1").PasteSpecial xlPasteValuesAndNumberFormatting

        Set wsNew = wbNew.Worksheets.Add

    Next wsSrc

    strFileName = ThisWorkbook.Sheets("Batch Control Slip").Range("C10").Value

    ' save file in same directory as original workbook
    wbNew.SaveAs ThisWorkbook.Path & Application.FileSeparator & strFileName
    
End Sub

Open in new window

Shums Faruk

ASKER

Hi Norie,

It was giving errors in line 11 for "Batch Control Template" as it must be "Batch Control Slip".

It was giving error in line 15, so I changed "wsNew.Range("A1").PasteSpecial xlPasteValuesAndNumberFormatting" to wsNew.Cells(1, 1).PasteSpecial xlPasteValues
wsNew.Cells(1, 1).PasteSpecial xlPasteFormats"

Then it was giving error in line 24, so I changed "wbNew.SaveAs ThisWorkbook.Path & Application.FileSeparator & strFileName" to "wbNew.SaveAs ThisWorkbook.Path & "\" & "Summary" & "_" & strFileName & ".xls".

Everything is working perfect.

The problem is renaming every sheets in new workbook & there was our company logo on "Batch Control Slip" which goes off while transfer. See if you could help with this.

ASKER CERTIFIED SOLUTION

Norie

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Shums Faruk

ASKER

Perfect

Sorry to ask you stupid question. I am new to Excel 2010, how will I check the name of the logo?

Norie

Quick question.

Which sheets actually use the SpellNumber function?

Any sheet that doesn't can be copied directly without all the copying/paste special etc.

The advantage of that would be that things like pictures, eg logos, will also be copied over.

Shums Faruk

ASKER

Hi Norie,

Sheets("Fax-Transmittal") uses SpellNumber.

The shapes we want to move is in Sheets("Batch Control Slip") and there is formula in G20:G

Yes Invoices & Coding Template sheet can go directly without paste special

I added below code after Next wsSrc

Windows("Payment Process.xlsm").Activate
        ActiveSheet.Shapes.Range(Array("Picture 1", "Picture 2")).Select
        Selection.Copy
        Range("C10").Select
        wbNew.Activate
        ActiveSheet.Range("F2").PasteSpecial
        Range("C10").Select

Open in new window

Its copying the picture too, how could I get align as per usedranged for column and top of the sheet?

Shums Faruk

ASKER

Ok Sir,

I am here as per below, which is working perfectly well:

Sub CopyWSToNewWB()
Dim wbNew As Workbook
Dim wsNew As Worksheet
Dim wsSrc As Worksheet
Dim myR As Range
Dim strNewFileName As String

    Set wbNew = Workbooks.Add(xlWBATWorksheet)

    Set wsNew = wbNew.Worksheets(1)

    For Each wsSrc In ThisWorkbook.Worksheets(Array("INVOICES", "Fax-Transmittal", "Coding Template", "Batch Control Slip"))

        If wsNew Is Nothing Then Set wsNew = wbNew.Worksheets.Add
        
        wsNew.Name = wsSrc.Name
        
        wsSrc.Cells.Copy

        wsNew.Range("A1").PasteSpecial xlPasteValues

        wsNew.Range("A1").PasteSpecial xlPasteFormats
        
        wsNew.Range("A1").Select
        
        Set wsNew = Nothing
        
  Next wsSrc
        Windows("Payment Process.xlsm").Activate
        ActiveSheet.Shapes.Range(Array("Picture 1", "Picture 2")).Select
        Selection.Copy
        Range("C10").Select
        wbNew.Activate
        ActiveSheet.Range("G2").PasteSpecial
    'scale the picture to the width of the column
        Set myR = Range("G2")
        Selection.ShapeRange.Top = myR.Top
        Selection.ShapeRange.Left = myR.Left
        Selection.ShapeRange.IncrementLeft (myR.Width - Selection.ShapeRange.Width) / 2
        Range("C10").Select
        
    strNewFileName = ThisWorkbook.Sheets("Batch Control Slip").Range("C10").Value

    ' save file in same directory as original workbook
    wbNew.SaveAs ThisWorkbook.Path & "\Summary_" & strNewFileName
    wbNew.Close
    
End Sub

Open in new window

Now I realized the page setup of all the worksheet is disturbed. I set that too for all the sheets.

Thanks a million. You are Genius.

Norie

Glad you got it sorted yourself.

Had a few ideas about the logo thing but seems like you've dealt with that.:)