VBA Multiple Excel files and need a particular range of Data with the same format.

S

sksanjeev786

Well-known Member
Joined
Aug 5, 2020
Messages
998
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Hi Team,

I have multiple files in excel and each Excel file has the same Tab name with "Overall Results" I need the data from only Overall Results tabs from multiple files from range A1 to D60 with the same format to mention the Screenshot of excel in each sheet. can anyone help me wiht this..

Below is the screenshot of the data file.

1657331819314.png
 

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
Sort by date Sort by votes
Try this, it will let you select workbooks and save each workbook's Overall Results sheet A1:D60 to a separate worksheet on the active workbook:
VBA Code: 
Sub LoopFiles()
'https://www.mrexcel.com/board/threads/vba-multiple-excel-files-and-need-a-particular-range-of-data-with-the-same-format.1210177/
Set fso = CreateObject("Scripting.FileSystemObject")
    Debug.Print fso.GetBaseName(ActiveWorkbook.Name)
Dim wb As Workbook
Set wb = ThisWorkbook

On Error GoTo OnErr

Dim fDialog As FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)


'Optional: FileDialog properties
fDialog.AllowMultiSelect = True
fDialog.Title = "Select files"
fDialog.InitialFileName = "C:\"
'Optional: Add filters
fDialog.Filters.Clear
fDialog.Filters.Add "Custom Excel Files", "*.xlsx, *.xlsm, *.xls, *.csv"
fDialog.Filters.Add "All files", "*.*"
 
'Show the dialog. -1 means success!
If fDialog.Show = -1 Then
     'loop through each file
     For Each it In fDialog.SelectedItems
        'get the filename to make a new tab
        SourceName = fso.GetBaseName(it)
        'check to see if this tabname exists
        For i = 1 To ThisWorkbook.Worksheets.Count
            'if the tabname exists
            If wb.Sheets(i).Name = SourceName Then
                'if it does, set a counter and go to then next file
                Count = 1
                Exit For
            End If
        Next i
        'if the name doesn't exist
        If Count = 0 Then
            'create a new worksheet with the filename
            wb.Sheets.Add.Name = SourceName
            'open a hidden instance of Excel
            Dim app As New Excel.Application
            app.Visible = False 'Visible is False by default, so this isn't necessary
            'open the latest workbook
            Dim book As Excel.Workbook
            Set book = app.Workbooks.Add(it)
            'with the latest workbook, Overall Results worksheet
            With book.Worksheets("Overall Results")
                'copy A1:D60
                .Range("A1:D60").SpecialCells(xlCellTypeVisible).Copy
                'paste it into this workbook in the latest worksheet, cell A1
                wb.Worksheets(SourceName).Range("A1").PasteSpecial xlPasteValues
                'this next copy/paste is to reduce the clipboard down to a smaller size
                'so Excel won't ask if you want to save it on exit.
                .Range("A1").SpecialCells(xlCellTypeVisible).Copy
                wb.Worksheets(SourceName).Range("A1").PasteSpecial xlPasteValues
            End With
            Application.CutCopyMode = False
            book.Close SaveChanges:=False
            app.Quit
            Set app = Nothing
        Else
            'put the name in an array
            DupWS = DupWS & Chr(10) & SourceName
            'reset the count
            Count = 0
        End If
    Next
Else
    'if the cancel button is selected
    End
End If
'if there are duplicates, show what was skipped.
If Len(DupWS) > 0 Then
    x = MsgBox("These Worksheets already exist in" & vbCrLf & "this workbook and were not imported:" & DupWS, vbExclamation)
End If
End

OnErr:
    book.Close SaveChanges:=False
    app.Quit
    Set app = Nothing
    x = MsgBox("Error: " & Err & Chr(10) & Err.Description, vbCritical)
   
End Sub

I did not put in error checking to see if the "Overall Results" exists on every workbook.
 
Last edited:
Upvote 0
Solution
portews said:
Try this, it will let you select workbooks and save each workbook's Overall Results sheet A1:D60 to a separate worksheet on the active workbook:
VBA Code: 
Sub LoopFiles()
'https://www.mrexcel.com/board/threads/vba-multiple-excel-files-and-need-a-particular-range-of-data-with-the-same-format.1210177/
Set fso = CreateObject("Scripting.FileSystemObject")
    Debug.Print fso.GetBaseName(ActiveWorkbook.Name)
Dim wb As Workbook
Set wb = ThisWorkbook

On Error GoTo OnErr

Dim fDialog As FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)


'Optional: FileDialog properties
fDialog.AllowMultiSelect = True
fDialog.Title = "Select files"
fDialog.InitialFileName = "C:\"
'Optional: Add filters
fDialog.Filters.Clear
fDialog.Filters.Add "Custom Excel Files", "*.xlsx, *.xlsm, *.xls, *.csv"
fDialog.Filters.Add "All files", "*.*"
 
'Show the dialog. -1 means success!
If fDialog.Show = -1 Then
     'loop through each file
     For Each it In fDialog.SelectedItems
        'get the filename to make a new tab
        SourceName = fso.GetBaseName(it)
        'check to see if this tabname exists
        For i = 1 To ThisWorkbook.Worksheets.Count
            'if the tabname exists
            If wb.Sheets(i).Name = SourceName Then
                'if it does, set a counter and go to then next file
                Count = 1
                Exit For
            End If
        Next i
        'if the name doesn't exist
        If Count = 0 Then
            'create a new worksheet with the filename
            wb.Sheets.Add.Name = SourceName
            'open a hidden instance of Excel
            Dim app As New Excel.Application
            app.Visible = False 'Visible is False by default, so this isn't necessary
            'open the latest workbook
            Dim book As Excel.Workbook
            Set book = app.Workbooks.Add(it)
            'with the latest workbook, Overall Results worksheet
            With book.Worksheets("Overall Results")
                'copy A1:D60
                .Range("A1:D60").SpecialCells(xlCellTypeVisible).Copy
                'paste it into this workbook in the latest worksheet, cell A1
                wb.Worksheets(SourceName).Range("A1").PasteSpecial xlPasteValues
                'this next copy/paste is to reduce the clipboard down to a smaller size
                'so Excel won't ask if you want to save it on exit.
                .Range("A1").SpecialCells(xlCellTypeVisible).Copy
                wb.Worksheets(SourceName).Range("A1").PasteSpecial xlPasteValues
            End With
            Application.CutCopyMode = False
            book.Close SaveChanges:=False
            app.Quit
            Set app = Nothing
        Else
            'put the name in an array
            DupWS = DupWS & Chr(10) & SourceName
            'reset the count
            Count = 0
        End If
    Next
Else
    'if the cancel button is selected
    End
End If
'if there are duplicates, show what was skipped.
If Len(DupWS) > 0 Then
    x = MsgBox("These Worksheets already exist in" & vbCrLf & "this workbook and were not imported:" & DupWS, vbExclamation)
End If
End

OnErr:
    book.Close SaveChanges:=False
    app.Quit
    Set app = Nothing
    x = MsgBox("Error: " & Err & Chr(10) & Err.Description, vbCritical)
  
End Sub

I did not put in error checking to see if the "Overall Results" exists on every workbook.
Click to expand...


This is Superrrr Fast and PERFECT..!!!!!

Thank you so much for your hard work and time on this. Really it is going to help us in many ways....!!!!

Once again thank you...............!!!!!
 
Upvote 0
portews said:
Try this, it will let you select workbooks and save each workbook's Overall Results sheet A1:D60 to a separate worksheet on the active workbook:
VBA Code: 
Sub LoopFiles()
'https://www.mrexcel.com/board/threads/vba-multiple-excel-files-and-need-a-particular-range-of-data-with-the-same-format.1210177/
Set fso = CreateObject("Scripting.FileSystemObject")
    Debug.Print fso.GetBaseName(ActiveWorkbook.Name)
Dim wb As Workbook
Set wb = ThisWorkbook

On Error GoTo OnErr

Dim fDialog As FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)


'Optional: FileDialog properties
fDialog.AllowMultiSelect = True
fDialog.Title = "Select files"
fDialog.InitialFileName = "C:\"
'Optional: Add filters
fDialog.Filters.Clear
fDialog.Filters.Add "Custom Excel Files", "*.xlsx, *.xlsm, *.xls, *.csv"
fDialog.Filters.Add "All files", "*.*"
 
'Show the dialog. -1 means success!
If fDialog.Show = -1 Then
     'loop through each file
     For Each it In fDialog.SelectedItems
        'get the filename to make a new tab
        SourceName = fso.GetBaseName(it)
        'check to see if this tabname exists
        For i = 1 To ThisWorkbook.Worksheets.Count
            'if the tabname exists
            If wb.Sheets(i).Name = SourceName Then
                'if it does, set a counter and go to then next file
                Count = 1
                Exit For
            End If
        Next i
        'if the name doesn't exist
        If Count = 0 Then
            'create a new worksheet with the filename
            wb.Sheets.Add.Name = SourceName
            'open a hidden instance of Excel
            Dim app As New Excel.Application
            app.Visible = False 'Visible is False by default, so this isn't necessary
            'open the latest workbook
            Dim book As Excel.Workbook
            Set book = app.Workbooks.Add(it)
            'with the latest workbook, Overall Results worksheet
            With book.Worksheets("Overall Results")
                'copy A1:D60
                .Range("A1:D60").SpecialCells(xlCellTypeVisible).Copy
                'paste it into this workbook in the latest worksheet, cell A1
                wb.Worksheets(SourceName).Range("A1").PasteSpecial xlPasteValues
                'this next copy/paste is to reduce the clipboard down to a smaller size
                'so Excel won't ask if you want to save it on exit.
                .Range("A1").SpecialCells(xlCellTypeVisible).Copy
                wb.Worksheets(SourceName).Range("A1").PasteSpecial xlPasteValues
            End With
            Application.CutCopyMode = False
            book.Close SaveChanges:=False
            app.Quit
            Set app = Nothing
        Else
            'put the name in an array
            DupWS = DupWS & Chr(10) & SourceName
            'reset the count
            Count = 0
        End If
    Next
Else
    'if the cancel button is selected
    End
End If
'if there are duplicates, show what was skipped.
If Len(DupWS) > 0 Then
    x = MsgBox("These Worksheets already exist in" & vbCrLf & "this workbook and were not imported:" & DupWS, vbExclamation)
End If
End

OnErr:
    book.Close SaveChanges:=False
    app.Quit
    Set app = Nothing
    x = MsgBox("Error: " & Err & Chr(10) & Err.Description, vbCritical)
  
End Sub

I did not put in error checking to see if the "Overall Results" exists on every workbook.
Click to expand...
Hi Portews,
Hope you are doing great

I need your support on the above macro

Previously above macro pulls only "Overall Results" tab from all the files now i need all the tabs from all the files with same code you have provide us earlier

Could you please help me with this

Regards,
Sanjeev
 
Upvote 0
Hi
sksanjeev786 said:
Hi Portews,
Hope you are doing great

I need your support on the above macro

Previously above macro pulls only "Overall Results" tab from all the files now i need all the tabs from all the files with same code you have provide us earlier

Could you please help me with this

Regards,
Sanjeev
Click to expand...
Hi Portews,

Could you please help us on above thigns

Regards
Sanjeev
 
Upvote 0
You want all the cells from all worksheets from all the workbooks copied into one workbook?
 
Upvote 0
Try this:

VBA Code: 
Sub LoopFilesAllWS()
'https://www.mrexcel.com/board/threads/vba-multiple-excel-files-and-need-a-particular-range-of-data-with-the-same-format.1210177/
Set fso = CreateObject("Scripting.FileSystemObject")
    Debug.Print fso.GetBaseName(ActiveWorkbook.Name)
Dim wb As Workbook
Set wb = ThisWorkbook
Dim wksht As Worksheet

On Error GoTo OnErr

Dim fDialog As FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)

'Optional: FileDialog properties
fDialog.AllowMultiSelect = True
fDialog.Title = "Select files"
fDialog.InitialFileName = "C:\"
'Optional: Add filters
fDialog.Filters.Clear
fDialog.Filters.Add "Custom Excel Files", "*.xlsx, *.xlsm, *.xls, *.csv"
fDialog.Filters.Add "All files", "*.*"
 
'Show the dialog. -1 means success!
If fDialog.Show = -1 Then
    'loop through each file
     For Each it In fDialog.SelectedItems
        'open a hidden instance of Excel
        Dim app As New Excel.Application
        app.Visible = False 'Visible is False by default, so this isn't necessary
        'open the latest workbook
        Dim book As Excel.Workbook
        Set book = app.Workbooks.Add(it)

        'with the latest workbook
        With book
            For Each wksht In book.Worksheets
                'check to see if this tabname exists
                For i = 1 To wb.Worksheets.Count
                    'if the tabname exists
                    If wb.Sheets(i).Name = wksht.Name Or wb.Sheets(i).Name = .Name & " - " & wksht.Name Then
                        'if it does, set a counter and go to then next file
                        Count = 1
                        Exit For
                    End If
                Next i
                    'if the name doesn't exist
                    If Count = 0 Then
                        'create a new worksheet with the filename
                        wb.Sheets.Add.Name = .Name & " - " & wksht.Name
                        'copy the used range in the latest workbook, latest sheet
                        wksht.UsedRange.Copy
                        'activate the target workbook
                        wb.Activate
                        'copy the worksheet to this workbook
                        wb.Sheets(.Name & " - " & wksht.Name).Range("a1").PasteSpecial Paste:=xlPasteValues
                        'copy one cell to avoid a clipboard warning
                        wksht.Range("A1").Copy
                    Else
                        'put the name in an list
                        dupWS = dupWS & Chr(10) & .Name & " - " & wksht.Name
                        'reset the count
                        Count = 0
                    End If
           Next wksht
        End With
            'close and quit the hidden workbook after the last worksheet
            Application.CutCopyMode = False
            book.Close SaveChanges:=False
            app.Quit
            Set app = Nothing
    Next it
Else
    'if the cancel button is selected
    End
End If


'if there are duplicates, show what was skipped.
If Len(dupWS) > 0 Then
    x = MsgBox("These Worksheets already exist in" & vbCrLf & "this workbook and were not imported:" & dupWS, vbExclamation)
End If
End

OnErr:
    book.Close SaveChanges:=False
    app.Quit
    Set app = Nothing
    x = MsgBox("Error: " & Err & Chr(10) & Err.Description, vbCritical)
   
End Sub
 
Upvote 0
W
portews said:
Try this:

VBA Code: 
Sub LoopFilesAllWS()
'https://www.mrexcel.com/board/threads/vba-multiple-excel-files-and-need-a-particular-range-of-data-with-the-same-format.1210177/
Set fso = CreateObject("Scripting.FileSystemObject")
    Debug.Print fso.GetBaseName(ActiveWorkbook.Name)
Dim wb As Workbook
Set wb = ThisWorkbook
Dim wksht As Worksheet

On Error GoTo OnErr

Dim fDialog As FileDialog
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)

'Optional: FileDialog properties
fDialog.AllowMultiSelect = True
fDialog.Title = "Select files"
fDialog.InitialFileName = "C:\"
'Optional: Add filters
fDialog.Filters.Clear
fDialog.Filters.Add "Custom Excel Files", "*.xlsx, *.xlsm, *.xls, *.csv"
fDialog.Filters.Add "All files", "*.*"
 
'Show the dialog. -1 means success!
If fDialog.Show = -1 Then
    'loop through each file
     For Each it In fDialog.SelectedItems
        'open a hidden instance of Excel
        Dim app As New Excel.Application
        app.Visible = False 'Visible is False by default, so this isn't necessary
        'open the latest workbook
        Dim book As Excel.Workbook
        Set book = app.Workbooks.Add(it)

        'with the latest workbook
        With book
            For Each wksht In book.Worksheets
                'check to see if this tabname exists
                For i = 1 To wb.Worksheets.Count
                    'if the tabname exists
                    If wb.Sheets(i).Name = wksht.Name Or wb.Sheets(i).Name = .Name & " - " & wksht.Name Then
                        'if it does, set a counter and go to then next file
                        Count = 1
                        Exit For
                    End If
                Next i
                    'if the name doesn't exist
                    If Count = 0 Then
                        'create a new worksheet with the filename
                        wb.Sheets.Add.Name = .Name & " - " & wksht.Name
                        'copy the used range in the latest workbook, latest sheet
                        wksht.UsedRange.Copy
                        'activate the target workbook
                        wb.Activate
                        'copy the worksheet to this workbook
                        wb.Sheets(.Name & " - " & wksht.Name).Range("a1").PasteSpecial Paste:=xlPasteValues
                        'copy one cell to avoid a clipboard warning
                        wksht.Range("A1").Copy
                    Else
                        'put the name in an list
                        dupWS = dupWS & Chr(10) & .Name & " - " & wksht.Name
                        'reset the count
                        Count = 0
                    End If
           Next wksht
        End With
            'close and quit the hidden workbook after the last worksheet
            Application.CutCopyMode = False
            book.Close SaveChanges:=False
            app.Quit
            Set app = Nothing
    Next it
Else
    'if the cancel button is selected
    End
End If


'if there are duplicates, show what was skipped.
If Len(dupWS) > 0 Then
    x = MsgBox("These Worksheets already exist in" & vbCrLf & "this workbook and were not imported:" & dupWS, vbExclamation)
End If
End

OnErr:
    book.Close SaveChanges:=False
    app.Quit
    Set app = Nothing
    x = MsgBox("Error: " & Err & Chr(10) & Err.Description, vbCritical)
  
End Sub
Click to expand...
Waw..!!!!!

Thank you, Thank you so much Portews :)
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
VBA to merge 2 tables across many sheets
Replies
1
Views
147
alansidman
A
VinceF
  • Question Question
VBA For Screenshot...With A Twist
2
Replies
14
Views
405
jolivanes
jolivanes
C
  • Question Question
Create upload file based on order form
Replies
2
Views
127
Christine4711
C
A
  • Question Question
Excel file on SharePoint used at the same time
Replies
1
Views
124
ExcelToDAX
E
A
  • Solved
VBA code to extract a table
Replies
5
Views
237
Anthony47
A

Forum statistics

Threads
1,223,919
Messages
6,175,368
Members
452,638
Latest member
Oluwabukunmi

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top