How to multiselect Worksheets-CodePudding

I need to be the name of worksheets are multiple. Because the original template sometimes named "Parts" sometimes names "Function Manifold" or got a few names more.

Basically, the name of the worksheet is got three or four different name.

Now, i only know how to use only one Worksheet name - "Parts"

Sub CopyFilesContent()
   Dim oFSO As Object, oFolder As Object, oFile As Object, wb As Workbook, ws As Worksheet
   Dim i As Long, j As Long, LR As Long, lastR As Long, wsFN As Worksheet

   Set oFSO = CreateObject("Scripting.FileSystemObject")
   Set oFolder = oFSO.GetFolder("C:\Users\user name\Downloads\Test Consolidate Folder\2021")
   Set wsFN = Workbooks("Consolidate.xlsm").Worksheets("Master")
   
   For Each oFile In oFolder.Files
       Set wb = Workbooks.Open(oFile)    'open the workbook to copy from

################################## THIS PART PLEASE HELP ###################################

       Set ws = wb.Worksheets("Parts") 'Parts sheet, to copy from. Use here the necessary one if not this
      
       LR = wsFN.Cells(Rows.Count, 1).End(xlUp).Row   1       'last empty row in the master FileName sheet
       wsFN.Cells(LR) = oFile.Name                            'write the wb to copy from name
       lastR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row - 2 'last row in the sheet where to copy from
       
       
       
       ws.Cells(4, 13).FormulaR1C1 = "=MATCH(1,C[-12],0)"
       ws.Cells(4, 13).Copy
       Cells(4, 13).PasteSpecial Paste:=xlPasteValues
       
       firstR = ws.Cells(4, 13)
       
       ws.Cells(3, 13).Copy
       Range("K" & firstR & ":K" & lastR).PasteSpecial Paste:=xlPasteValues
       ws.Range("A10:N" & lastR).Copy wsFN.Range("A" & LR   1) 'copy the necessary range
       wb.Close False  'close the workbook, without saving it
   Next oFile
   
   
       Columns("A:A").Select
       Selection.SpecialCells(xlCellTypeBlanks).Select
       Selection.EntireRow.Delete
   
End Sub

After some comment below , I've tried by doing this code But when I debug, it didn't go in to the worksheet that named "Parts".

please help

And I updated the code as suggested by @VBasic2008, But still the code didn't go in even though got worksheet name as I declare below "Parts"

Sub CopyFilesContent()
    
    Const ProcTitle As String = "Copy Files Contents"
    Const wsNamesList As String = "Parts,Function Manifold,Manifolding,Whatever"
    
    Dim oFSO As Object, oFolder As Object, oFile As Object, wb As Workbook, ws As Worksheet
    Dim i As Long, j As Long, LR As Long, lastR As Long, wsFN As Worksheet

    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder("C:\Users\user name\Downloads\Test Consolidate Folder\2021")
    Set wsFN = Workbooks("Consolidate.xlsm").Worksheets("Master")
    
    For Each oFile In oFolder.Files
        Set wb = Workbooks.Open(oFile)    'open the workbook to copy from
        Set ws = RefFirstExistingWorksheet(wb, wsNamesList)
        If Not ws Is Nothing Then
        
            LR = wsFN.Cells(Rows.Count, 1).End(xlUp).Row   1       'last empty row in the master FileName sheet
            wsFN.Cells(LR) = oFile.Name                            'write the wb to copy from name
            lastR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row - 2 'last row in the sheet where to copy from
        
        
        
            ws.Cells(4, 13).FormulaR1C1 = "=MATCH(1,C[-12],0)"
            ws.Cells(4, 13).Copy
            Cells(4, 13).PasteSpecial Paste:=xlPasteValues
        
            firstR = ws.Cells(4, 13)
        
            ws.Cells(3, 13).Copy
            Range("K" & firstR & ":K" & lastR).PasteSpecial Paste:=xlPasteValues
            ws.Range("A10:N" & lastR).Copy wsFN.Range("A" & LR   1) 'copy the necessary range

            wb.Close False  'close the workbook, without saving it
        Else
            MsgBox "Parts worksheet not found in file '" & oFile.Name & "'.", _
                vbCritical, ProcTitle
        End If
    Next oFile
   
        Columns("A:A").Select
        Selection.SpecialCells(xlCellTypeBlanks).Select
        Selection.EntireRow.Delete
    
End Sub

Function RefFirstExistingWorksheet( _
    ByVal wb As Workbook, _
    ByVal WorksheetNamesList As String, _
    Optional ByVal Delimiter As String = "Parts,Function Manifold") _
As Worksheet
    If wb Is Nothing Then Exit Function
    If Len(WorksheetNamesList) = 0 Then Exit Function
    Dim wsNames() As String: wsNames = Split(WorksheetNamesList, Delimiter)
    Dim ws As Worksheet
    Dim wsName As Variant
    For Each wsName In wsNames
        On Error Resume Next
        Set RefFirstExistingWorksheet = wb.Worksheets(wsName)
        On Error GoTo 0
        If Not RefFirstExistingWorksheet Is Nothing Then
            Exit For
        End If
    Next wsName
End Function

CodePudding user response：

Reference First Existing Worksheet

In your CopyFilesContent procedure, you could utilize the RefFirstExistingWorksheet function. Try testing as is, and afterward add the rest of the code.

Sub CopyFilesContent()
    
    Const ProcTitle As String = "Copy Files Contents"
    Const wsNamesList As String = "Parts,Function Manifold,Manifolding,Whatever"
    
    Dim oFSO As Object, oFolder As Object, oFile As Object, wb As Workbook, ws As Worksheet
    Dim i As Long, j As Long, LR As Long, lastR As Long, wsFN As Worksheet

    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder("C:\Users\user name\Downloads\Test Consolidate Folder\2021")
    Set wsFN = Workbooks("Consolidate.xlsm").Worksheets("Master")
    
    For Each oFile In oFolder.Files
        Set wb = Workbooks.Open(oFile)    'open the workbook to copy from
        Set ws = RefFirstExistingWorksheet(wb, wsNamesList)
        If Not ws Is Nothing Then
            ' Remove when done testing:
            MsgBox "Found worksheet '" & ws.Name & "'.", _
                vbInformation, ProcTitle
            ' Continue...
            'LR = ...

            wb.Close False  'close the workbook, without saving it
        Else
            MsgBox "Parts worksheet not found in file '" & oFile.Name & "'.", _
                vbCritical, ProcTitle
        End If
    Next oFile
    
    ' Continue
    'Columns...
    
End Sub

Function RefFirstExistingWorksheet( _
    ByVal wb As Workbook, _
    ByVal WorksheetNamesList As String, _
    Optional ByVal Delimiter As String = ",") _
As Worksheet
    If wb Is Nothing Then Exit Function
    If Len(WorksheetNamesList) = 0 Then Exit Function
    Dim wsNames() As String: wsNames = Split(WorksheetNamesList, Delimiter)
    Dim ws As Worksheet
    Dim wsName As Variant
    For Each wsName In wsNames
        On Error Resume Next
        Set RefFirstExistingWorksheet = wb.Worksheets(wsName)
        On Error GoTo 0
        If Not RefFirstExistingWorksheet Is Nothing Then
            Exit For
        End If
    Next wsName
End Function

Here's a tester to better understand the function: in a new workbook, add this code to a standard module. Now, add sheets, rename them and modify wsNamesList etc.

Sub Tester()
    Const wsNamesList As String = "Sheet150,Sheet22,Sheet1"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = RefFirstExistingWorksheet(wb, wsNamesList)
    
    If Not ws Is Nothing Then
        Debug.Print ws.Name
    Else
        Debug.Print "Nope"
    End If
End Sub