How to Import Specific Sheet to Another Workbook with VBA

Question

I try to create a program that can collect every "UTP" sheet in one folder into one "Master UTP" workbook (located in the same folder)

So, first I need to read all file xls in folder. Copy "UTP" sheet and paste it to "Master UTP". Then do looping again.

This is the code that I make so far in "Master UTP":

Public Sub myImport()
Dim sPathName As String, sFileName As String
Dim sourceWb As Workbook, targetWb As Workbook

Set sourceWb = ActiveWorkbook

sPathName = ThisWorkbook.Path & "\"
sFileName = Dir(sPathName & "*.xls", vbNormal)

Do While Len(sFileName) > 0
    sFileName = sPathName & sFileName

    If sFileName <> sourceWb Then
        Set targetWb = Workbooks.Open(sName)
        targetWb.Sheets("UTP").Copy After:=sourceWb.Sheets("Master UTP")
        targetWb.Close
    End If

    sFileName = Dir
Loop
End Sub

There still some mistake in this program. Please help. Thanks.

Answer 1

Building on @chrisneilsen 's solution, here'a more compact code:

Option Explicit

Public Sub myImport()
    Dim sPathName As String, sFileName As String
    Dim targetSht As Worksheet

    Set targetSht = ActiveWorkbook.Worksheets("Master UTP")

    sPathName = ThisWorkbook.Path & "\"
    sFileName = Dir(sPathName & "*.xls", vbNormal)

    Do While Len(sFileName) > 0
        If sFileName <> targetSht.Parent.Name Then
            On Error Resume Next
            With Workbooks.Open(sPathName & sFileName)
                .Sheets("UTP").Copy After:=targetSht
                .Close False
            End With
            On Error GoTo 0
        End If
        sFileName = Dir
    Loop
End Sub

which should be even slightly more compacted if it can be safely assumed that ActiveWorkbook is a "macro" one, ie with a "xlsm" type in its name, so that it can never match any "xls" name:

Option Explicit

Public Sub myImport()
    Dim sPathName As String, sFileName As String
    Dim targetSht As Worksheet

    Set targetSht = ActiveWorkbook.Worksheets("Master UTP")

    sPathName = ThisWorkbook.Path & "\"
    sFileName = Dir(sPathName & "*.xls", vbNormal)

    Do While Len(sFileName) > 0
        On Error Resume Next
        With Workbooks.Open(sPathName & sFileName)
            .Sheets("UTP").Copy After:=targetSht
            .Close False
        End With
        On Error GoTo 0
        sFileName = Dir
    Loop
End Sub

Finally, you could appreciate eliminate the flickering at any xls file opening, so you maight enclose the loop inside Application.ScreenUpdating = False/True statements:

Option Explicit

Public Sub myImport()
    Dim sPathName As String, sFileName As String
    Dim targetSht As Worksheet

    Set targetSht = ActiveWorkbook.Worksheets("Master UTP")

    sPathName = ThisWorkbook.Path & "\"
    sFileName = Dir(sPathName & "*.xls", vbNormal)

    Application.ScreenUpdating = False
    Do While Len(sFileName) > 0
        On Error Resume Next
        With Workbooks.Open(sPathName & sFileName)
            .Sheets("UTP").Copy After:=targetSht
            .Close False
        End With
        On Error GoTo 0
        sFileName = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Answer 2

First issue is you try an open sName rather than sFileName (Use of Option Explicit would detect this error)

Second issue, you are comparing string to a workbook in If sFileName <> sourceWb Then

Third issue, workbook.name doesn't include the path

Your code, refactored, and some error handling added

Public Sub myImport()
    Dim sPathName As String, sFileName As String
    Dim sourceWb As Workbook, targetWb As Workbook
    Dim ws As Worksheet

    Set sourceWb = ActiveWorkbook

    sPathName = ThisWorkbook.Path & "\"
    sFileName = Dir(sPathName & "*.xls", vbNormal)

    Do While Len(sFileName) > 0
        If sFileName <> sourceWb.Name Then ' <-- sourceWb.Name does not include path
            Set targetWb = Nothing
            On Error Resume Next ' <-- in case Open fails
                Set targetWb = Workbooks.Open(sPathName & sFileName) '<-- use correct variable sFileName
            On Error GoTo 0
            If Not targetWb Is Nothing Then
                Set ws = Nothing
                On Error Resume Next ' <-- in case sheet does not exist
                    Set ws = targetWb.Worksheets("UTP")
                On Error Resume Next
                If Not ws Is Nothing Then
                    ws.Copy After:=sourceWb.Worksheets("Master UTP")
                End If
                targetWb.Close False 
            End If
        End If

        sFileName = Dir
    Loop
End Sub

Answer 3

Your code looks fine except for the error where you try and open the other workbooks. You try and open workbooks from the variable sName which is never used. You also reset the sFileName variable needlessly, instead try using sPathName & sFileName as the input for Workbooks.Open() .

Also, you try and compare the sFileName to the sourceWb which are two different data types, instead compare sFileName to sourceWb.Name .

Finally, you assume that the workbook will have a worksheet named "UTP" , if it doesn't the code will crash. Instead check if the sheet exists first. View https://stackoverflow.com/a/6040390/8520655 for more information.

Please view below for example; Public Sub myImport() Dim sPathName As String, sFileName As String Dim sourceWb As Workbook, targetWb As Workbook

Set sourceWb = ActiveWorkbook
ActiveSheet.Cells(1, 1).Value = sourceWb.Name

sPathName = ThisWorkbook.Path & "\"
sFileName = Dir(sPathName & "*.xls", vbNormal)

Do While Len(sFileName) > 0
    ActiveSheet.Cells(1, 2).Value = sFileName
    If sFileName <> sourceWb.Name Then
        Set targetWb = Workbooks.Open(sPathName & sFileName)

        If SheetExists("UTP", targetWb) Then
            targetWb.Sheets("UTP").Copy After:=sourceWb.Sheets("Master UTP")
        End If

        targetWb.Close
    End If

    sFileName = Dir
Loop
End Sub

Function SheetExists(SheetName As String, Optional wb As Excel.Workbook)
    Dim s As Excel.Worksheet
    If wb Is Nothing Then Set wb = ThisWorkbook
    On Error Resume Next
    Set s = wb.Sheets(SheetName)
    On Error GoTo 0
    SheetExists = Not s Is Nothing
End Function