Extracting a range of non-contiguous cells from either of Two sheets in a folder of worksheets

[Nandakishore]

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

 

[JoeMo]

I haven't looked at all your code, but here is an untested modification that may be of interest. It includes a function to check which, if any, of the two sheets exists in each workbook that is opened.

Sub PIdataextraction()
Dim myFile As String, path As String, copyrange
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)
    If SheetExists("Summary1") Then
        Set copyrange = Sheets("Summary1").Range("B4,E7,E9,E11,E13,E15,I12,J22,C24,C25,C26,I11,R16")
    ElseIf SheetExists("extract1") Then
        Set copyrange = Sheets("extract1").Range("B4,E7,E9,E11,E13,E15,I12,J22,C24,C25,C26,I11,R16")
    Else
        MsgBox "Neither summary1 nor extract1 exists in workbook " & Workbooks(path _
            & myFile).Name & vbCrLf & vbCrLf & "Exiting sub"
        Exit Sub
    End If
    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 cel
    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
Function SheetExists(shName As String) As Boolean
SheetExists = False
For Each sh In ActiveWorkbook.Sheets
If sh.Name = shName Then
    SheetExists = True
    Exit For
End If
Next sh
End Function

 

[Alex Blakenburg]

I am sure Joe's version will work for you but since I have already done a slightly different version I may as well post it.
The other change I made that would work in Joe's version as well is that since you are only copying values you can use an straight out assigment ("=") which is slightly faster.

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

 

[Nandakishore]

I haven't looked at all your code, but here is an untested modification that may be of interest. It includes a function to check which, if any, of the two sheets exists in each workbook that is opened.

Sub PIdataextraction()
Dim myFile As String, path As String, copyrange
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)
    If SheetExists("Summary1") Then
        Set copyrange = Sheets("Summary1").Range("B4,E7,E9,E11,E13,E15,I12,J22,C24,C25,C26,I11,R16")
    ElseIf SheetExists("extract1") Then
        Set copyrange = Sheets("extract1").Range("B4,E7,E9,E11,E13,E15,I12,J22,C24,C25,C26,I11,R16")
    Else
        MsgBox "Neither summary1 nor extract1 exists in workbook " & Workbooks(path _
            & myFile).Name & vbCrLf & vbCrLf & "Exiting sub"
        Exit Sub
    End If
    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 cel
    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
Function SheetExists(shName As String) As Boolean
SheetExists = False
For Each sh In ActiveWorkbook.Sheets
If sh.Name = shName Then
    SheetExists = True
    Exit For
End If
Next sh
End Function

Thanks a lot!! This really helps Keep learning new stuff here

 

[Nandakishore]

Thank you!! One more quick ques!! Is there a way i can add the excel file name (workbook name) at the end of the output file each time it runs? Thank you

 

[Alex Blakenburg]

Is there a way i can add the excel file name (workbook name) at the end of the output file each time it runs?

I would normally add some additional variables but this should work.
After the command line Next,
add this

        Cells(erow, col).Value = shtSrc.Parent.Name

I also noticed that I didn't reset the error trapping, so after the line End If
please add

On Error GoTo 0