Help creating a file joining different other files

Dear friends,

I'm in a situation where I'm really struggling to get it solved. I really don't know if what I'm asking is even possible to do with VBA code, but here it goes:

I have one folder with hundreds of files in a format that is editable with a text editor. I want to join all of those files into one (to use on other application). But the thing is, to create this file there are some conditions that have to be met so that the created file can be read with by the other application.

The files are sorted alphabetically. I have file a.sp2 , b.sp2 , c.sp2 , ....

The code should start reading a.sp2 file and all this file content should be copied to the new-file, then it should read b.sp2 and it should only copy from line 83 to the end of b.sp2 file to the end of the previously created file. Then it should read c.sp2 file and copy from line 83 to the end of c.sp2 file to the new created file , and so on...

So basically the code should copy all the content of the first file and then join the content (starting on line 83 to the end) from all the other files in that folder.

I will attach a zip file with example files (a.sp2 , b.sp2 , c.sp2) and a desired output for the code (output.sp2).

Thank you so much for any help given

Best Regards

You can do it in Power Query.

Change the folder name and the name of the first file in the if test.

Code:

---

let
    _folder.path = "D:\Projects\_8 Community\_forums\VBAExpress\VBAX - 64985 - Join Files",
    _first.file = "a.sp2",

    Source = Folder.Files(_folder.path),
    hiddenFile.Filter = Table.SelectRows(Source, each [Attributes]?[Hidden]? <> true),
    contentCol.Add = Table.AddColumn(hiddenFile.Filter, "Files", each #"Transform File from VBAX - 64985 - Join Files"([Content])),
    sourceCol.Rename = Table.RenameColumns(contentCol.Add, {"Name", "Source.Name"}),
    surplusCols.Remove = Table.SelectColumns(sourceCol.Rename, {"Source.Name", "Files"}),
    errorRows.Remove = Table.RemoveRowsWithErrors(surplusCols.Remove, {"Files"}),
    fileContent.Expand = Table.ExpandTableColumn(errorRows.Remove, "Files", Table.ColumnNames(#"Transform File from VBAX - 64985 - Join Files"(#"Sample File"))),
    dataCol.Rename = Table.RenameColumns(fileContent.Expand,{{"Column1", "Data"}}),
    data.Type = Table.TransformColumnTypes(dataCol.Rename,{{"Source.Name", type text}, {"Data", type text}}),
    idCol.Add = Table.AddColumn(data.Type, "Id", each 1),

    TableType = Value.Type(Table.AddColumn(idCol.Add, "Running Cost", each null, type number)),
    fnRunningSum = (MyTable as table) as table =>
    let
        Source = Table.Buffer(MyTable),
        TableType = Value.Type(Table.AddColumn(Source, "Running Cost", each null, type number)),
        Cumulative = List.Skip(List.Accumulate(Source[Id],{0},(cumulative,Id) => cumulative & {List.Last(cumulative) + Id})),
        AddedRunningSum = Table.FromColumns(Table.ToColumns(Source)&{Cumulative},TableType)
    in
        AddedRunningSum,
    rowsGrouped = Table.Group(idCol.Add, {"Source.Name"}, {{"GroupedData", fnRunningSum, TableType}}),
    rowsExpanded = Table.ExpandTableColumn(rowsGrouped , "GroupedData", {"Data", "Running Cost"}, {"Data", "Running Cost"}),
    tokeepCol.Add = Table.AddColumn(rowsExpanded, "Keepers", each if [Source.Name] = _first.file then true else if [Running Cost] > 83 then true else false),
    originalData.Keep = Table.SelectColumns(tokeepCol.Add,{"Data"})
in
    originalData.Keep

---

Dear xld,

Thank you so much for trying to help me!! I don't know what do refer by "Power Query". I have tried to use the code on excel VBA programmer but I'm getting an error. I suspect this code isn't to be used in this way.

Is it possible to adapt this code to be used on the VBA excel programmer?

Thank you so much!

Dear xld,

I have realised that PowerQuery is an add-on for MSOffice. The problem is that I'm currently using Office 2007 which is not supported by PowerQuery. Is there any way around without using PowerQuery?


Thanks

Edit: It also doesn't work on Windows Vista (What I am using) :crying:

2007! I feel for you, that is a poor Excel.

This VBA should do it.

Code:

---

Option Explicit

Public Sub GetFiles()
Dim target As Worksheet
Dim wb As Workbook
Dim parentFolder As Object
Dim file As Object
Dim nextrow As Long
Dim myFolder As String
Dim notFirst As Boolean

    Application.ScreenUpdating = False

    With ThisWorkbook
   
        Set target = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
        target.Name = "Merged Data"
    End With
   
    With Application.FileDialog(msoFileDialogFolderPicker)
   
        .Title = "Select Folder"
        .InitialFileName = vbNullString
        .AllowMultiSelect = False
       
        If .Show = -1 Then
       
            If .SelectedItems.Count > 0 Then
         
                myFolder = .SelectedItems(1)
            End If
        Else
       
            Exit Sub
        End If
    End With
 
    Set parentFolder = CreateObject("Scripting.FileSystemObject").GetFolder(myFolder)
   
    nextrow = 1
    For Each file In parentFolder.Files
   
        Set wb = GetFile(file.Path, IIf(notFirst, 83, 1))
        wb.Worksheets(1).UsedRange.Copy target.Cells(nextrow, 1)
        nextrow = target.Cells(target.Rows.Count, "A").End(xlUp).Row + 1
        wb.Close SaveChanges:=False
        notFirst = True
    Next file
   
    Application.ScreenUpdating = True
End Sub

Private Function GetFile( _
    ByVal Filepath As String, _
    ByVal Startrow As Long) As Workbook
    Workbooks.OpenText Filename:=Filepath, _
                        Origin:=xlMSDOS, _
                        Startrow:=Startrow, _
                        DataType:=xlDelimited, _
                        TextQualifier:=xlDoubleQuote, _
                        ConsecutiveDelimiter:=False, _
                        Tab:=True, Semicolon:=False, _
                        Comma:=False, _
                        Space:=False, _
                        Other:=False, _
                        FieldInfo:=Array(1, 1), _
                        TrailingMinusNumbers:=True
    Set GetFile = ActiveWorkbook
End Function

---

Dear xld,

Thank you so much for trying to help me!! It really means a lot!! Thank you!!

Well, I have tried to run the code and this is what happens: It asks me for a folder, which I pick the one with the .sp2 files, and then after I select "OK" I get the following message:

"myfilename.xlsm is already open. If you open again again, all changes made will be lost. Do you want to open again myfilename.xlsm?"

If I press Yes - I get back to where I was
If I press No - I get the following error: https://i.imgur.com/8IsHzL0.png (Method 'OpenText' of object 'Workbooks' failed)

Again, thank you so much for your time!!

EDITED: The link of the error

Do you have that .xlsm file in your sp2 folder, it sounds like it.

Not sure about the problem as I don't have it, but does this sort it?

Code:

---

    Option Explicit
   
    Public Sub GetFiles()
    Dim target As Worksheet
    Dim wb As Workbook
    Dim parentFolder As Object
    Dim file As Object
    Dim nextrow As Long
    Dim myFolder As String
    Dim notFirst As Boolean
   
        Application.ScreenUpdating = False
   
        With ThisWorkbook
       
            Set target = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
            target.Name = "Merged Data"
        End With
       
        With Application.FileDialog(msoFileDialogFolderPicker)
       
            .Title = "Select Folder"
            .InitialFileName = vbNullString
            .AllowMultiSelect = False
           
            If .Show = -1 Then
           
                If .SelectedItems.Count > 0 Then
             
                    myFolder = .SelectedItems(1)
                End If
            Else
           
                Exit Sub
            End If
        End With
   
        Set parentFolder = CreateObject("Scripting.FileSystemObject").GetFolder(myFolder)
       
        nextrow = 1
        For Each file In parentFolder.Files
       
            If Mid$(file.Path, InStrRev(file.pah, "."), 99) = ".sp2" Then
           
                Set wb = GetFile(file.Path, IIf(notFirst, 83, 1))
                wb.Worksheets(1).UsedRange.Copy target.Cells(nextrow, 1)
                nextrow = target.Cells(target.Rows.Count, "A").End(xlUp).Row + 1
                wb.Close SaveChanges:=False
                notFirst = True
            End If
        Next file
       
        Application.ScreenUpdating = True
    End Sub
   
    Private Function GetFile( _
        ByVal Filepath As String, _
        ByVal Startrow As Long) As Workbook
        Workbooks.OpenText Filename:=Filepath, _
                            Origin:=xlMSDOS, _
                            Startrow:=Startrow, _
                            DataType:=xlDelimited, _
                            TextQualifier:=xlDoubleQuote, _
                            ConsecutiveDelimiter:=False, _
                            Tab:=True, Semicolon:=False, _
                            Comma:=False, _
                            Space:=False, _
                            Other:=False, _
                            FieldInfo:=Array(1, 1), _
                            TrailingMinusNumbers:=True
        Set GetFile = ActiveWorkbook
    End Function

---

Dear xld,

Thank you again for your reply! You are right. I had my .xlsm on my sp2 folder. Now I have moved the .xlsm file to other folder and I can run without errors the 1st code you have given to me.

The code now works without any problem, in the end I got my Excel sheet with the information from the .sp2 files but I don't think it exports to any .sp2 file, at least I can't find where the export file is. Am I doing something wrong?

I'm sorry for my questions and again thanks a lot for your help!


EDIT- I have clicked on File -> Save as Unicode Text (.txt) and got a file almost like I wanted to be. On this print I show some differences that I don't know if it can be solved. Please see the image that I post here: https://i.imgur.com/ogUWfmT.png

Again, can't thank you enough for your help!

The code wasn't saving it, you were not missing anything.

This version saves it as "Merged Data.sp2" in the same folder, as an MS-DOS text file, seems to be okay, but you will know better than I.

Code:

---

Option Explicit

Public Sub GetFiles()
Const TARGET_SHEET_NAME As String = "Merged Data"
Dim target As Worksheet
Dim wb As Workbook
Dim parentFolder As Object
Dim file As Object
Dim nextrow As Long
Dim myFolder As String
Dim notFirst As Boolean

    Application.ScreenUpdating = False

    With ThisWorkbook
   
        Call DeleteSheet(TARGET_SHEET_NAME)
       
        Set target = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
        target.Name = TARGET_SHEET_NAME
    End With
   
    With Application.FileDialog(msoFileDialogFolderPicker)
   
        .Title = "Select Folder to Merge"
        .InitialFileName = vbNullString
        .AllowMultiSelect = False
       
        If .Show = -1 Then
       
            If .SelectedItems.Count > 0 Then
         
                myFolder = .SelectedItems(1)
            End If
        Else
       
            Exit Sub
        End If
    End With
 
    Set parentFolder = CreateObject("Scripting.FileSystemObject").GetFolder(myFolder)
   
    nextrow = 1
    For Each file In parentFolder.Files
   
        If Mid$(file.Path, InStrRev(file.Path, "."), 99) = ".sp2" Then
       
            Set wb = GetFile(file.Path, IIf(notFirst, 83, 1))
            wb.Worksheets(1).UsedRange.Copy target.Cells(nextrow, 1)
            nextrow = target.Cells(target.Rows.Count, "A").End(xlUp).Row + 1
            wb.Close SaveChanges:=False
            notFirst = True
        End If
    Next file
   
    Worksheets(TARGET_SHEET_NAME).Move
    ActiveWorkbook.SaveAs Filename:=myFolder & Application.PathSeparator & TARGET_SHEET_NAME & ".sp2", _
                          FileFormat:=xlTextMSDOS, _
                          CreateBackup:=False
    ActiveWorkbook.Close
   
    Application.ScreenUpdating = True
End Sub

Private Function GetFile( _
    ByVal Filepath As String, _
    ByVal Startrow As Long) As Workbook
    Workbooks.OpenText Filename:=Filepath, _
                        Origin:=xlMSDOS, _
                        Startrow:=Startrow, _
                        DataType:=xlDelimited, _
                        TextQualifier:=xlDoubleQuote, _
                        ConsecutiveDelimiter:=False, _
                        Tab:=True, Semicolon:=False, _
                        Comma:=False, _
                        Space:=False, _
                        Other:=False, _
                        FieldInfo:=Array(1, 1), _
                        TrailingMinusNumbers:=True
    Set GetFile = ActiveWorkbook
End Function

Private Function DeleteSheet(ByVal sh As String) As Boolean

    Application.DisplayAlerts = False
   
    On Error Resume Next
    ActiveWorkbook.Worksheets(sh).Delete
    On Error GoTo 0

    Application.DisplayAlerts = True
End Function

---

Dear xld,

Again I can't thank you enough from trying to help me! You have been very considerate to me! Thank you!

Well, I have tried the new code and it runs without any problem. Automatically saves the .sp2 file to the folder perfectly.

The only thing that is not working so well is for example on line 55 and 85 of the merged.sp2. If you compare this file with the output.sp2 file that I originally attached in the first post you can see this kind of differences: https://i.imgur.com/xKjs9Gb.png

Are these issues solvable?

Again much respect for your willing to help me!

Can anyone help me out on this question?

Thanks