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.

You’re going to get a lot more help if you post a specific error/question about specific functionality... — John R, Feb 08 '18 at 02:47

score 1 · Answer 1 · answered Feb 08 '18 at 08:25

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, i.e. 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

score 0 · Answer 2 · answered Feb 08 '18 at 03:09

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

score 0 · Answer 3 · answered Feb 08 '18 at 03:12

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

score 0 · Answer 4 · edited Jul 11 '23 at 10:55

Sub ImportFirstSheet()
    Dim filePath As Variant
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim wsDestination As Worksheet
    Dim destRange As Range
    
    ' Prompt the user to select the source workbook
    filePath = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")
    
    ' Check if a file was selected
    If filePath <> False Then
        ' Open the source workbook
        Set wbSource = Workbooks.Open(filePath)
        
        ' Set the source worksheet (the first sheet)
        Set wsSource = wbSource.Sheets(1)
        
        ' Set the destination worksheet (the active sheet)
        Set wsDestination = ThisWorkbook.ActiveSheet
        
        ' Clear existing contents in the destination worksheet starting from cell B1
        wsDestination.Range("A2").CurrentRegion.Clear
        
        ' Copy the data from the source worksheet to the destination worksheet
        wsSource.UsedRange.Copy
        
        ' Paste the data to the destination worksheet starting from cell B1
        Set destRange = wsDestination.Range("A2")
        destRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        
        ' Close the source workbook without saving changes
        wbSource.Close SaveChanges:=False
        
        ' Inform the user that the import is complete
        MsgBox "Import complete.", vbInformation
    Else
        ' Inform the user that no file was selected
        MsgBox "No file selected.", vbExclamation
    End If
End Sub


Sub HighlightCellsContainingSearchString()
    Dim searchString As String
    Dim searchRange As Range
    Dim cell As Range
    
    ' Prompt the user to enter the search string
    searchString = InputBox("Enter the search string:", "Search String")
    
    ' Check if the search string is entered
    If Len(searchString) > 0 Then
        ' Set the search range as the active sheet
        Set searchRange = ActiveSheet.UsedRange
        
        ' Clear previous highlighting
        searchRange.Interior.ColorIndex = xlNone
        
        ' Loop through each cell in the search range
        For Each cell In searchRange
            ' Check if the cell value contains the search string
            If InStr(1, cell.Value, searchString, vbTextCompare) > 0 Then
                ' Highlight the cell
                cell.Interior.Color = RGB(255, 0, 0) ' Change the RGB values to the desired highlight color
            End If
        Next cell
        
        ' Inform the user that the highlighting is complete
        MsgBox "Highlighting complete.", vbInformation
    Else
        ' Inform the user that no search string was entered
        MsgBox "No search string entered.", vbExclamation
    End If
End Sub

Thank you for contributing to the Stack Overflow community. This may be a correct answer, but it’d be really useful to provide additional explanation of your code so developers can understand your reasoning. This is especially useful for new developers who aren’t as familiar with the syntax or struggling to understand the concepts. **Would you kindly [edit] your answer to include additional details for the benefit of the community?** While you’re at it, please improve your formatting. — Jeremy Caney, Jul 08 '23 at 00:14

How to Import Specific Sheet to Another Workbook with VBA

4 Answers4