View Single Post
 
Old 03-13-2015, 01:46 AM
dapeamel dapeamel is offline Windows 8 Office 2010 64bit
Novice
 
Join Date: Feb 2015
Location: sweden
Posts: 10
dapeamel is on a distinguished road
Default Merge files if filenames match a certain value

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:




Code:
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
Reply With Quote