elmnas
03-13-2015, 01:45 AM
Hello all,
I have made following code that loops through each file in a folder I select.
when the loop finds a file contains "*NoTrans.xls"
a filename can be example:
test_en_NoTrans.xls
I have a filter that removes "*NoTrans.xls"
so result:
test_en.xls
I need to to make a function to open the file also merging the file into the file
I looping with
test_en_noTrans.xls
Could someone help me?
See code below:
Sub files()
Application.DisplayAlerts = False
Dim wb As Workbook
Dim MyPath As String
Dim MyFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
MyPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
MyPath = MyPath
If MyPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*NoTrans.xls"
'Target Path with Ending Extention
MyFile = Dir(MyPath & myExtension)
'Loop through each Excel file in folder
Do While MyFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=MyPath & MyFile)
'gör något
MyFileNoTransOpen = ActiveWorkbook.Name
myActFilePath = Application.ActiveWorkbook.Path
myOpenNoTrans = Left(MyFileNoTransOpen, (InStrRev(MyFileNoTransOpen, ".", -1, vbTextCompare) - 9))
myLangFile = myOpenNoTrans & ".xls"
MsgBox myOpenNoTrans
MsgBox myLangFile
MsgBox myActFilePath
' MsgBox ActiveWorkbook.Name
'Save and Close Workbook
wb.Close savechanges:=True
'Get next file name
MyFile = Dir
Loop
'Message Box when tasks are completed
' MsgBox "Nu är alla celler på Rad 1 Dolda!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I have made following code that loops through each file in a folder I select.
when the loop finds a file contains "*NoTrans.xls"
a filename can be example:
test_en_NoTrans.xls
I have a filter that removes "*NoTrans.xls"
so result:
test_en.xls
I need to to make a function to open the file also merging the file into the file
I looping with
test_en_noTrans.xls
Could someone help me?
See code below:
Sub files()
Application.DisplayAlerts = False
Dim wb As Workbook
Dim MyPath As String
Dim MyFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
MyPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
MyPath = MyPath
If MyPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*NoTrans.xls"
'Target Path with Ending Extention
MyFile = Dir(MyPath & myExtension)
'Loop through each Excel file in folder
Do While MyFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=MyPath & MyFile)
'gör något
MyFileNoTransOpen = ActiveWorkbook.Name
myActFilePath = Application.ActiveWorkbook.Path
myOpenNoTrans = Left(MyFileNoTransOpen, (InStrRev(MyFileNoTransOpen, ".", -1, vbTextCompare) - 9))
myLangFile = myOpenNoTrans & ".xls"
MsgBox myOpenNoTrans
MsgBox myLangFile
MsgBox myActFilePath
' MsgBox ActiveWorkbook.Name
'Save and Close Workbook
wb.Close savechanges:=True
'Get next file name
MyFile = Dir
Loop
'Message Box when tasks are completed
' MsgBox "Nu är alla celler på Rad 1 Dolda!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub