Help creating a file joining different other files

[ropbasuel]

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

[Bob Phillips]

You can do it in Power Query.

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


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

[ropbasuel]

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!

[ropbasuel]

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:

[Bob Phillips]

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

This VBA should do it.


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

[ropbasuel]

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

[Bob Phillips]

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?


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

[ropbasuel]

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!

[Bob Phillips]

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.


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

[ropbasuel]

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!

[ropbasuel]

Can anyone help me out on this question?

Thanks