Extracting a range of non-contiguous cells within number of excel files in a particular folder (data has to be pulled from either of 2 UNIQUE SHEETS)

I have the below code for pulling data (range of cells) that are non-contiguous and pasting them in a new sheet. However, the code needs to look for the data in either of the 2 sheets , namely - "summary1" or "extract1".

[Note- Only one of the two sheets would be available in each file] I can successfully pull for one of them but if i add both of them using "On Error Resume Next" i get an error. Kindly guide me on how to resolve this!

Any suggestions or tips are much appreciate!!

Code:

Sub PIdataextraction()

Dim myFile As String, path As String
Dim erow As Long, col As Long

path = "C:\Users\New\"
myFile = Dir(path & "*.xl??")

Application.ScreenUpdating = False

Do While myFile <> ""
Workbooks.Open (path & myFile)
Windows(myFile).Activate

Set copyrange = Sheets("summary1").Range("B4,E7,E9,E11,E13,E15,I12,J22,C24,C25,C26,I11,R16")

On Error Resume Next

Set copyrange = Sheets("extract1").Range("B4,E7,E9,E11,E13,E15,I12,J22,C24,C25,C26,I11,R16")

Windows("MasterFile.xlsm").Activate

erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

col = 1
For Each cel In copyrange
cel.Copy

Cells(erow, col).PasteSpecial xlPasteValues

col = col   1

Next

Windows(myFile).Close savechanges:=False
myFile = Dir()
Loop
Range("A:E").EntireColumn.AutoFit

Application.DisplayAlerts = True
Application.ScreenUpdating = True

MsgBox "Data has been Compiled,Please Check!"

End Sub

CodePudding user response：

Here's one approach which factors out the "find one of these sheets in a workbook" logic into a separate function.

Sub PIdataextraction()

    Const PTH As String = "C:\Users\New\" 'use const for fixed values
    Const RNG As String = "B4,E7,E9,E11,E13,E15,I12,J22,C24,C25,C26,I11,R16"
    
    Dim myFile As String, path As String, c As Range
    Dim erow As Long, col As Long, wb As Workbook, ws As Worksheet
    
    Application.ScreenUpdating = False
    
    erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).row
    myFile = Dir(PTH & "*.xl??")
    
    Do While myFile <> ""
        Set wb = Workbooks.Open(path & myFile)
        
        Set ws = FindFirstSheet(wb, Array("summary1", "extract1"))
        If Not ws Is Nothing Then       'check we got a sheet
            col = 1
            For Each c In ws.Range(RNG).Cells
                Sheet1.Cells(erow, col).Value = c.Value
                col = col   1
            Next c
            Sheet1.Cells(erow, col).Value = wb.Name '<<<<<<<<<<<<<<<<
            erow = erow   1
        Else
            Debug.Print "No sheet found in " & ws.Name
        End If
        
        wb.Close savechanges:=False
        myFile = Dir()
    Loop
    Range("A:E").EntireColumn.AutoFit
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    MsgBox "Data has been Compiled,Please Check!"

End Sub

'Given a workbook `wb`, return the first sheet found from 
'  an array of sheet names `SheetNames`
Function FindFirstSheet(wb As Workbook, SheetNames) As Worksheet
    Dim ws As Worksheet, s
    For Each s In SheetNames
        On Error Resume Next
        Set ws = wb.Worksheets(s)
        On Error GoTo 0
        If Not ws Is Nothing Then Exit For
    Next s
    Set FindFirstSheet = ws
End Function

CodePudding user response：

The following code worked for me. As usual thank you for your valuable inputs!! much appriciated

Sub PIdataextraction()

    Dim myFile As String, path As String
    Dim erow As Long, col As Long
   
    Dim shtSrc As Worksheet
    Dim copyrange As Range, cel As Range
   
    path = "C:\Users\New\"
    myFile = Dir(path & "*.xl??")
   
    Application.ScreenUpdating = False
   
    Do While myFile <> ""
        Workbooks.Open (path & myFile)
        Windows(myFile).Activate
       
        On Error Resume Next
        Set shtSrc = Worksheets("summary1")
        If Err = 9 Then
            On Error Resume Next
            Set shtSrc = Worksheets("extract1")
            If Err = 9 Then Exit Sub
            On Error GoTo 0
        End If
             
        Set copyrange = shtSrc.Range("B4,E7,E9,E11,E13,E15,I12,J22,C24,C25,C26,I11,R16")
       
        Windows("MasterFile.xlsm").Activate
       
        erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
       
        col = 1
        For Each cel In copyrange
            Cells(erow, col).Value = cel.Value   ' Equivalent of xlPasteValues
            col = col   1     
        Next
       
        Windows(myFile).Close savechanges:=False
        myFile = Dir()
    Loop
    Range("A:E").EntireColumn.AutoFit
   
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
   
    MsgBox "Data has been Compiled,Please Check!"

End Sub