PDA

View Full Version : [SOLVED] Modify code a bit, (combine function)



elmnas
03-12-2015, 03:30 AM
I got following code,

I need to put a location for sourcefiles in the code, but i want instead to have a dialogwindow See code below:




'The following code will combine all data into one excel workbook.
Sub CombineFiles_Step1()
'Declare Variables
Dim WorkbookDestination As Workbook
Dim WorkbookSource As Workbook
Dim WorksheetSource As Worksheet
Dim FolderLocation As String
Dim strFilename As String

Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False

'This line will need to be modified depending on location of source folder
FolderLocation = "C:\Users\daniel.elmnas.TT\Desktop\ko\FIle"

'Set the current directory to the the folder path.
ChDrive FolderLocation
ChDir FolderLocation

'Dialog box to determine which files to use. Use ctrl+a to select all files in folder.
SelectedFiles = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xls*), *.xls*", MultiSelect:=True)

'Create a new workbook
Set WorkbookDestination = Workbooks.Add(xlWBATWorksheet)
strFilename = Dir(FolderLocation & "\*.xls", vbNormal)

'Iterate for each file in folder
If Len(strFilename) = 0 Then Exit Sub


Do Until strFilename = ""

Set WorkbookSource = Workbooks.Open(FileName:=FolderLocation & "\" & strFilename)
Set WorksheetSource = WorkbookSource.Worksheets(1)
WorksheetSource.Copy After:=WorkbookDestination.Worksheets(WorkbookDestination.Worksheets.Count)
WorkbookSource.Close False
strFilename = Dir()

Loop
WorkbookDestination.Worksheets(1).Delete

Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub


Could someone help me ?

Thank you in advance

Bob Phillips
03-12-2015, 04:12 AM
'The following code will combine all data into one excel workbook.
Sub CombineFiles_Step1()
'Declare Variables
Dim WorkbookDestination As Workbook
Dim WorkbookSource As Workbook
Dim WorksheetSource As Worksheet
Dim FolderLocation As String
Dim strFilename As String


With Application.FileDialog(msoFileDialogFolderPicker)

.AllowMultiSelect = False
.Title = "Select folder"
If .Show = -1 Then

Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False

FolderLocation = .SelectedItems(1)

'Set the current directory to the the folder path.
ChDrive FolderLocation
ChDir FolderLocation

'Dialog box to determine which files to use. Use ctrl+a to select all files in folder.
SelectedFiles = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xls*), *.xls*", MultiSelect:=True)

'Create a new workbook
Set WorkbookDestination = Workbooks.Add(xlWBATWorksheet)
strFilename = Dir(FolderLocation & "\*.xls", vbNormal)

'Iterate for each file in folder
If Len(strFilename) = 0 Then Exit Sub


Do Until strFilename = ""

Set WorkbookSource = Workbooks.Open(Filename:=FolderLocation & "\" & strFilename)
Set WorksheetSource = WorkbookSource.Worksheets(1)
WorksheetSource.Copy After:=WorkbookDestination.Worksheets(WorkbookDestination.Worksheets.Count)
WorkbookSource.Close False
strFilename = Dir()

Loop
WorkbookDestination.Worksheets(1).Delete

Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End With
End Sub

elmnas
03-12-2015, 05:07 AM
'The following code will combine all data into one excel workbook.
Sub CombineFiles_Step1()
'Declare Variables
Dim WorkbookDestination As Workbook
Dim WorkbookSource As Workbook
Dim WorksheetSource As Worksheet
Dim FolderLocation As String
Dim strFilename As String


With Application.FileDialog(msoFileDialogFolderPicker)

.AllowMultiSelect = False
.Title = "Select folder"
If .Show = -1 Then

Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False

FolderLocation = .SelectedItems(1)

'Set the current directory to the the folder path.
ChDrive FolderLocation
ChDir FolderLocation

'Dialog box to determine which files to use. Use ctrl+a to select all files in folder.
SelectedFiles = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xls*), *.xls*", MultiSelect:=True)

'Create a new workbook
Set WorkbookDestination = Workbooks.Add(xlWBATWorksheet)
strFilename = Dir(FolderLocation & "\*.xls", vbNormal)

'Iterate for each file in folder
If Len(strFilename) = 0 Then Exit Sub


Do Until strFilename = ""

Set WorkbookSource = Workbooks.Open(Filename:=FolderLocation & "\" & strFilename)
Set WorksheetSource = WorkbookSource.Worksheets(1)
WorksheetSource.Copy After:=WorkbookDestination.Worksheets(WorkbookDestination.Worksheets.Count)
WorkbookSource.Close False
strFilename = Dir()

Loop
WorkbookDestination.Worksheets(1).Delete

Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End With
End Sub


Thank you Work aweosome:)

elmnas
03-12-2015, 05:09 AM
Could you help me to save the file to a new folder located in same folder as I open the target file in,
then save it with source name?

Thank you in advance.