Extracting a range of non-contiguous cells

Question

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

I would a function to see if the sheet exists. See this post https://stackoverflow.com/questions/6688131/test-or-check-if-sheet-exists — Kevin, Feb 03 '22 at 23:40

Tim Williams · Accepted Answer · 2022-02-04T22:00:04.803

1

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

edited Feb 04 '22 at 22:00

answered Feb 04 '22 at 00:43

Tim Williams

154,628
8
97
125

Hi Tim! Thank you for the response – Nandakishore Feb 04 '22 at 01:06
However, we receive a "VBA 1004 Error" while running the above code. This mostly has to do with - " Set ws = FindFirstSheet..." – Nandakishore Feb 04 '22 at 01:07
Note: The sheets ("summary1", "extract1") mentioned might not be the first sheet in the workbook. Their position might change – Nandakishore Feb 04 '22 at 01:27
For the error - make sure in your options (VBA editor >> Tools >> Options >> General) you don't have "Break on all errors" checked. "Break in class module" is a good option. The order of sheets in the workbook doesn't matter - it only searches by name. – Tim Williams Feb 04 '22 at 02:11
Just tested this, and it's working fine for me. Make sure you copy the entire code as-is. – Tim Williams Feb 04 '22 at 02:21
You meant `If Not ws Is Nothing Then Set FindFirstSheet = ws: Exit Function` or `Exit For` without the outer `Set FindFirstSheet = ws`. – VBasic2008 Feb 04 '22 at 02:38
@VBasic2008 - it works as-is in my testing. Maybe just a different pattern than you might use? Once the loop exits, ws is either a worksheet or Nothing. – Tim Williams Feb 04 '22 at 03:16
Sorry, you're right. It just looks more correct to me since `ws` is initially `Nothing`. – VBasic2008 Feb 04 '22 at 03:22

score 0 · Answer 2 · answered Feb 04 '22 at 13:59

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

Is there a way i can add excel file names at the end of each row i pull(results) i.e. for each workbook macro opens? This would help!! Thanks — Nandakishore, Feb 04 '22 at 14:01

Extracting a range of non-contiguous cells

2 Answers2

Linked