Solved: How to import multiple sheets from different files in same folder to main workbook

[halimi1306]

Hi, I have a problem to import multiple sheet to workbook. I need to import 170 sheets to my model as well as deleting old sheets. Appreciate if someone can solve my problem. Below i found VBA from Shrivallabha. (I'm new to vba)

Credit to Shrivallabha,



Sub ImportSheet()
Dim sImportFile As String, sFile As String
Dim sThisBk As Workbook
Dim vfilename As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sThisBk = ActiveWorkbook
sImportFile = Application.GetOpenFilename( _
FileFilter:="Microsoft Excel Workbooks, *.xls; *.xlsx", Title:="Open Workbook")
If sImportFile = "False" Then
MsgBox "No File Selected!"
Exit Sub


Else
vfilename = Split(sImportFile, "\")
sFile = vfilename(UBound(vfilename))
Application.Workbooks.Open Filename:=sImportFile


Set wbBk = Workbooks(sFile)
With wbBk
If SheetExists("Raw_Data") Then
Set wsSht = .Sheets("Raw_Data")
wsSht.Copy before:=sThisBk.Sheets("Sheet1")
Else
MsgBox "There is no sheet with name :Raw_Data in:" & vbCr & .Name
End If
wbBk.Close SaveChanges:=False
End With
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Private Function SheetExists(sWSName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets(sWSName)
If Not ws Is Nothing Then SheetExists = True
End Function

[shrivallabha]

Hi Halimi1306,
Kindly explain your situation before someone can help you out:
1. What do you mean by "Model"?
2. Do you have any specific criteria for deleting sheets in the "Model"?
3. Where do these 170 sheets reside e.g. in 170 workbooks which are placed in a single folder?

The above code would not be suitable for handling 170 sheets especially if it is residing many workbooks. Better way would be looping but then you need clarify your situation clearly. Post back with some samples (remove sensitive data) if needed.

[halimi1306]

Hi Halimi1306,
Kindly explain your situation before someone can help you out:
1. What do you mean by "Model"?
2. Do you have any specific criteria for deleting sheets in the "Model"?
3. Where do these 170 sheets reside e.g. in 170 workbooks which are placed in a single folder?

The above code would not be suitable for handling 170 sheets especially if it is residing many workbooks. Better way would be looping but then you need clarify your situation clearly. Post back with some samples (remove sensitive data) if needed.

1. It is consolidated and summary table contain all given informations from 170 sheets.

2. There's no specific criteria, but new sheets that I want to import must keep all the formats and formulas.

3. The sheets are placed in a single folder.

5788

[BrianMH]

So you have 170 workbooks with a single sheet and you just need to copy each of these sheets into your mainworkbook?

[halimi1306]

So you have 170 workbooks with a single sheet and you just need to copy each of these sheets into your mainworkbook?


Actually every workbooks consist of 3 sheets. It means, 170x3.
But for the sample here, I just put one sheet. Appreciate if u could shows me both situations, 1 single sheet and multiple sheets

[BrianMH]

Sub copysheets()
Dim wbCopy As Workbook
Dim wbPaste As Workbook
Dim sPath As String
Dim wsCopy As Worksheet
Set wbPaste = ThisWorkbook
Dim x As Integer
Dim arrFiles
sPath = svpth
If sPath = "" Then
MsgBox ("you have not selected a folder")
Exit Sub
End If
arrFiles = GetFiles(sPath)
For x = 0 To UBound(arrFiles)
If arrFiles(x) <> ThisWorkbook.FullName Then
Set wbCopy = Workbooks.Open(arrFiles(x))
For Each wsCopy In wbCopy.Sheets
wsCopy.Copy after:=wbPaste.Sheets(wbPaste.Sheets.Count)
wbCopy.Close (False)
Next wsCopy
End If
Next x

End Sub



Private Function GetFiles(strpath)
Dim fs, fl, f, x
Dim arr
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(strpath)
x = 0
ReDim arr(f.Files.Count - 1)
For Each fl In f.Files
arr(x) = fl
x = x + 1

Next
GetFiles = arr
End Function

Private Function svpth()
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
Dim strSelectedItem As String
With fd

.Title = "please choose a path"

If .Show = -1 Then
svpth = .SelectedItems.Item(1)
Else
End If

End With

End Function



This should do it for you no matter the number of sheets. It allows you to select a folder and take action on each workbook in the folder. It assumes that you are only putting workbooks in that folder. You can change it so you can select individual files if needed. Let me know if you want to see it that way.

[halimi1306]

Sub copysheets()
Dim wbCopy As Workbook
Dim wbPaste As Workbook
Dim sPath As String
Dim wsCopy As Worksheet
Set wbPaste = ThisWorkbook
Dim x As Integer
Dim arrFiles
sPath = svpth
If sPath = "" Then
MsgBox ("you have not selected a folder")
Exit Sub
End If
arrFiles = GetFiles(sPath)
For x = 0 To UBound(arrFiles)
If arrFiles(x) <> ThisWorkbook.FullName Then
Set wbCopy = Workbooks.Open(arrFiles(x))
For Each wsCopy In wbCopy.Sheets
wsCopy.Copy after:=wbPaste.Sheets(wbPaste.Sheets.Count)
wbCopy.Close (False)
Next wsCopy
End If
Next x

End Sub



Private Function GetFiles(strpath)
Dim fs, fl, f, x
Dim arr
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(strpath)
x = 0
ReDim arr(f.Files.Count - 1)
For Each fl In f.Files
arr(x) = fl
x = x + 1

Next
GetFiles = arr
End Function

Private Function svpth()
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
Dim strSelectedItem As String
With fd

.Title = "please choose a path"

If .Show = -1 Then
svpth = .SelectedItems.Item(1)
Else
End If

End With

End Function



This should do it for you no matter the number of sheets. It allows you to select a folder and take action on each workbook in the folder. It assumes that you are only putting workbooks in that folder. You can change it so you can select individual files if needed. Let me know if you want to see it that way.


Many thanks Brian. Let me try 1st.

[halimi1306]

It works, but could you show me how to delete existing sheets with same name, and how to select and copy specific sheet in workbook. Let say workbook 1 have 3 sheets, but I only want to copy sheet 1 and sheet 3. Thanks Brian. Almost there.

[BrianMH]

Sub copysheets()
Dim wbCopy As Workbook
Dim wbPaste As Workbook
Dim wsCopy As Worksheet
Set wbPaste = ThisWorkbook
Dim x As Integer
Dim arrFiles
arrFiles = svpth2
If IsEmpty(arrFiles) = True Then
MsgBox ("please select some files")
Exit Sub
End If
For x = 0 To UBound(arrFiles)
If arrFiles(x) <> ThisWorkbook.FullName Then
Set wbCopy = Workbooks.Open(arrFiles(x))
For Each wsCopy In wbCopy.Sheets
wsCopy.Copy after:=wbPaste.Sheets(wbPaste.Sheets.Count)
wbCopy.Close (False)
Next wsCopy
End If
Next x

End Sub

Private Function svpth2() As Variant
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Dim strSelectedItem As String
Dim f, x, files
x = 0
With fd
.AllowMultiSelect = True
.Title = "please choose files"
.Filters.Add "Excel Workbooks", "*.xls; *.xlsx; *.xlsb; *.xlsm", 1
If .Show = -1 Then
ReDim files(.SelectedItems.Count - 1)
For Each f In .SelectedItems
files(x) = f
x = x + 1
Next

svpth2 = files
End If

End With

End Function

This one lets you choose specific files

[shrivallabha]

Brian has already provided solution. Here's one more approach.
Option Explicit
Public Sub ImportSheetData()
Dim sFld As String, sFlPath As String, sFile As String
Dim vPath As Variant
Dim wb As Workbook, wbThisBk As Workbook
Dim ws As Worksheet
Dim i As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'For calling the deletion sub
Call DeleteOldSheets
Set wbThisBk = ThisWorkbook
'Getting the path
sFlPath = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")
If sFlPath = "False" Then
MsgBox "No Files Selected"
Exit Sub
Else
vPath = Split(sFlPath, "\")
sFld = ""
For i = LBound(vPath) To UBound(vPath)
If InStr(1, vPath(i), ".xls") = 0 Then
sFld = sFld & vPath(i) & "\"
End If
Next i
ChDir sFld
sFile = Dir("*.xls*")
Do While sFile <> ""
Set wb = Workbooks.Open(sFld & sFile)
For Each ws In wb.Sheets
ws.Copy after:=wbThisBk.Sheets(Sheets.Count)
Next ws
wb.Close False
sFile = Dir
Loop
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Sub DeleteOldSheets()
'Deleting old worksheets except Model Engine
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
If ws.Name <> "Model Engine (Read Only)" Then
ws.Delete
End If
Next ws
End Sub


I am also attaching workbook which you'd posted here. Pressing ALT + F8 will show you the macro ImportSheetData.
It will retain the summary sheet and delete rest of the worksheets.
It will loop through all workbooks (all sheets in them) in a given folder. I'd recommend you save a backup copy before you test things.

[BrianMH]

Ah for your next question it gets a bit more complicated. To copy specific sheets you would need to refer to them by their index or name. For instance

wbcopy.Sheets(array(1,3)).copy after:=wbpaste.sheets(1)
or
wbcopy.Sheets(array("in3-SC","In2-SC")).copy after:=wbpaste.sheets(1)

If you don't want to copy sheets that already have the same name as ones in your worksheet you would need to test each sheet name against the sheet name to be copied.

[BobBarker]

If you don't want to copy sheets that already have the same name as ones in your worksheet you would need to test each sheet name against the sheet name to be copied.


--
Or he could have a preliminary snippet of VB that removes duplicate files from the folder, or moves them elsewhere, before running the merge script. Alas I don't know how to code that in VB

[BrianMH]

My second post of code would allow you to select only the workbooks you wanted so you could skip the workbooks already imported. If all the workbooks had 1 sheet with the same name say Model Engine (Read Only) you could add an if statement to not copy that one.

[BrianMH]

Didn't see shrivallabha's post. In their post there is a nice bit to delete all sheets but the read only sheet so new sheets can be input. It all really depends on what exactly you are using it for and what your end goal is.

[halimi1306]

Brian has already provided solution. Here's one more approach.
Option Explicit
Public Sub ImportSheetData()
Dim sFld As String, sFlPath As String, sFile As String
Dim vPath As Variant
Dim wb As Workbook, wbThisBk As Workbook
Dim ws As Worksheet
Dim i As Integer
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'For calling the deletion sub
Call DeleteOldSheets
Set wbThisBk = ThisWorkbook
'Getting the path
sFlPath = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")
If sFlPath = "False" Then
MsgBox "No Files Selected"
Exit Sub
Else
vPath = Split(sFlPath, "\")
sFld = ""
For i = LBound(vPath) To UBound(vPath)
If InStr(1, vPath(i), ".xls") = 0 Then
sFld = sFld & vPath(i) & "\"
End If
Next i
ChDir sFld
sFile = Dir("*.xls*")
Do While sFile <> ""
Set wb = Workbooks.Open(sFld & sFile)
For Each ws In wb.Sheets
ws.Copy after:=wbThisBk.Sheets(Sheets.Count)
Next ws
wb.Close False
sFile = Dir
Loop
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Sub DeleteOldSheets()
'Deleting old worksheets except Model Engine
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
If ws.Name <> "Model Engine (Read Only)" Then
ws.Delete
End If
Next ws
End Sub


I am also attaching workbook which you'd posted here. Pressing ALT + F8 will show you the macro ImportSheetData.
It will retain the summary sheet and delete rest of the worksheets.
It will loop through all workbooks (all sheets in them) in a given folder. I'd recommend you save a backup copy before you test things.

TQ,

One more thing, how to add another sheet that I dont want to delete i.e. guideline sheet and macro control sheet

If ws.Name <> "Model Engine (Read Only)" Then
ws.Delete

[BrianMH]

Private Sub DeleteOldSheets()
dim ws as worksheet
For Each ws In ThisWorkbook.Sheets
If ws.Name <> "Model Engine (Read Only)" and ws.name <> "another sheet name and ws.name <> "yet another sheet name Then
ws.Delete
End If
Next ws
end sub

is one way

another way would be


Private Sub DeleteOldSheets()
dim ws as worksheet
For Each ws In ThisWorkbook.Sheets
select case ws.name
case "Model Engine (Read Only)", "another name", "yet another name"
'do nothing
case else
ws.delete
end select
end sub
Next ws

Btw you can always add this sub to my code and call it at the beginning.

[halimi1306]

Private Sub DeleteOldSheets()
dim ws as worksheet
For Each ws In ThisWorkbook.Sheets
If ws.Name <> "Model Engine (Read Only)" and ws.name <> "another sheet name and ws.name <> "yet another sheet name Then
ws.Delete
End If
Next ws
end sub

is one way

another way would be


Private Sub DeleteOldSheets()
dim ws as worksheet
For Each ws In ThisWorkbook.Sheets
select case ws.name
case "Model Engine (Read Only)", "another name", "yet another name"
'do nothing
case else
ws.delete
end select
end sub
Next ws

Btw you can always add this sub to my code and call it at the beginning.

TQ very much Brian as wll as Shrivallabha. My problem SOLVED! TQ TQ TQ