CODEWITHSUNDEEP
excelvba
Spacepope
Spacepope

Reputation: 13

Copy specific sheets to new document - Excel VBA

I've been challenged with copying the "Entry" tabs from 4 excel files into a new document called "Data Upload" on a regular basis.

I am new to VBA but am hoping there is an automated way to run this procedure. I have attempted to use the following code but receive

Run Time Error 9 Subscript Out of range

On this line:

Sheets(wSht).Copy Before:=ThisWorkbook.Sheets(1)

Full code:

Sub CombineSheets()

    Dim sPath As String
    Dim sFname As String
    Dim wBk As Workbook
    Dim wSht As Variant

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    sPath = InputBox("Enter a full path to workbooks")
    ChDir sPath
    sFname = InputBox("Enter a filename pattern")
    sFname = Dir(sPath & "\" & sFname & ".xl*", vbNormal)
    wSht = InputBox("Enter a worksheet name to copy")

    Do Until sFname = ""
        Set wBk = Workbooks.Open(sFname)
        Windows(sFname).Activate
        Sheets(wSht).Copy Before:=ThisWorkbook.Sheets(1)
        wBk.Close False
        sFname = Dir()
    Loop

    ActiveWorkbook.Save

    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

Would really appreciate any advice on where this is going wrong or an example of a simplified way to do this.

Upvotes: 1

Views: 563

Answers (1)

QHarr
QHarr

Reputation: 84465

I think your problem is either here:

sFname = InputBox("Enter a filename pattern")
sFname = Dir(sPath & "\" & sFname & ".xl*", vbNormal)

Let's say i inputed .xlsm as a pattern i then get

sFname = ".xlsm"

sFname = path & ".xlsm" & ".xl*"

This is invalid.

Or, sheet may not be present you are trying to copy.

Notes: you need to handle the case of where the sheet may not be present to copy, or the workbook hasn't be found due to invalid file mask entry and also decide if you want to rename the copied sheets or leave them as mySheet, mySheet(2) etc.

Sub CombineSheets()
Dim sPath As String
Dim sFname As String
Dim wBk As Workbook
Dim wSht As Variant

Application.EnableEvents = False
Application.ScreenUpdating = False

sPath = InputBox("Enter a full path to workbooks")
ChDir sPath

sFname = InputBox("Enter a filename pattern") 'You will need some checks added here e.g. did user input ".xlsm" or "xlsm" etc

sFname = Dir(sPath & "\" & "*" & sFname, vbNormal) 'Additional * added to match different file names for the mask 
wSht = InputBox("Enter a worksheet name to copy")

Do Until sFname = ""

    On Error Resume Next 
    Set wBk = Workbooks.Open(sFname)
    Windows(sFname).Activate
    Sheets(wSht).Copy Before:=ThisWorkbook.Sheets(1)
    wBk.Close False
    On Error GoTo 0

    sFname = Dir()
Loop

ActiveWorkbook.Save
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub

Upvotes: 1

Related Questions