Save as text file in a certain format similar to an xml

P

PippaThePointer

New Member
Joined
Sep 21, 2023
Messages
24
Office Version
  1. 2016
Platform
  1. Windows
Hi,
Hoping for some simple advice as my brain is cooked today.
I have a data sheet that contains column A 'Size' and then Column B,C,D contain text.
I would like to run a vba to save the data as a text file, but i need it in a certain way.

The resulting text file ideally would be one file but the data grouped into <begindoc> <enddoc> from B,C,D and ideally also grouped by same data in Column A (Size). This one text file would then be saved to a certain location with .mergefile as the extention

SizeFirstSecondThird
Size1duplicate=2,FileA.pdfduplicate=0,FileA.pdfduplicate=2,FileA.pdf
Size1duplicate=0,FileB.pdfduplicate=0,FileB.pdfduplicate=1,FileB.pdf
Size2duplicate=2,FileC.pdfduplicate=2,FileC.pdfduplicate=2,FileC.pdf
Size2duplicate=2,FileD.pdfduplicate=2,FileD.pdfduplicate=2,FileD.pdf
Size2duplicate=2,FileE.pdfduplicate=2,FileE.pdfduplicate=2,FileE.pdf

inputfolder=C:\testfileinputlocation
outputfolder=C:\testfileoutputlocation
reportfile=C:\testlogfilelocation\ProcessingLog.htm
overwrite=no
padtoeven=no
author=Me
title=filename
// First output document is data from column N for each size in column C
<begindoc>
duplicate=2,FileA.pdf
duplicate=0,FileB.pdf
document=First-Size1.pdf
<enddoc>
// Second output document
<begindoc>
duplicate=0,FileA.pdf
duplicate=0,FileB.pdf
document=Second-Size1.pdf
<enddoc>
// Third output document
<begindoc>
duplicate=2,FileA.pdf
duplicate=1,FileB.pdf
document=Third-Size1.pdf
<enddoc>
// repeat again for next size....
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
Sort by date Sort by votes
One possibility
VBA Code: 
Sub MakeFile()
    Dim WB As Workbook
    Dim WS As Worksheet, WSD As Worksheet
    Dim rng As Range, R As Range, rng2 As Range
    Dim I As Long, LastRow As Long, DestRow As Long, DestColumn As Long
    Dim VA As Variant
    Dim DocName As String, LastSize As String, OutFile As String
    Dim inputfolder As String, outputfolder As String, reportfile As String, overwrite As String, padtoeven As String, author As String, title As String
    
    '===============User data ========================
    inputfolder = "C:\testfileinputlocation"
    'outputfolder = "C:\testfileoutputlocation"
    outputfolder = "C:\Users\223103252\Documents\TestFiles\"
    reportfile = "C:\testlogfilelocation\ProcessingLog.htm"
    overwrite = "no"
    padtoeven = "no"
    author = "Me"
    title = "filename"
    
    'Output File
    OutFile = outputfolder & "TestFile.Merge"
    '=================================================
    Application.ScreenUpdating = False
    Set WB = ActiveWorkbook
    Set WS = ActiveSheet
        
    'Add temporary worksheet and copy data to it.
    On Error Resume Next
    Application.DisplayAlerts = False
    ThisWorkbook.Worksheets("$TempSheet").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Set WSD = ThisWorkbook.Worksheets.Add
    WSD.Name = "$TempSheet"
    
    With WS
        Set rng2 = .Range("A2:D" & .Range("A" & .Rows.Count).End(xlUp).Row)
    End With
    rng2.Copy WSD.Range("A1") 'copy data to temporary worksheet
    
    'create formatted text
    With WSD
        Set rng = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
        For Each R In rng
            For I = 1 To 3
                R.Offset(0, I).Value = R.Offset(0, I).Value & "$" & I
            Next I
        Next R
        
        For I = 2 To 3
            LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
            rng.Offset(, I).Resize(, 1).Cut .Cells(LastRow + 1, 2)
            rng.Copy .Cells(LastRow + 1, 1)
        Next I
        
        'Sort
        .UsedRange.Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlYes
        
        Set rng = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
        
        DestRow = 1
        DestColumn = 5
        
        'Write header information
        WriteLine WSD, "inputfolder  = " & inputfolder, DestRow, DestColumn
        WriteLine WSD, "outputfolder  = " & outputfolder, DestRow, DestColumn
        WriteLine WSD, "reportfile  = " & reportfile, DestRow, DestColumn
        WriteLine WSD, "overwrite  = " & overwrite, DestRow, DestColumn
        WriteLine WSD, "padtoeven  = " & padtoeven, DestRow, DestColumn
        WriteLine WSD, "author  = " & author, DestRow, DestColumn
        WriteLine WSD, "title  = " & title, DestRow, DestColumn
        
        'Build formatted text
        LastSize = ""
        For Each R In rng
            R.Value = R.Value & "$" & Right(R.Offset(, 1).Value, 1)
            With R.Offset(, 1)
                VA = Split(.Value, "$")
                .Value = VA(0)
            End With
            If LastSize = "" Then
                WriteLine WSD, "<begindoc>", DestRow, DestColumn
            ElseIf R.Value <> LastSize Then
                WriteLine WSD, DocName, DestRow, DestColumn
                WriteLine WSD, "<enddoc>", DestRow, DestColumn
                WriteLine WSD, "<begindoc>", DestRow, DestColumn
            End If
            WriteLine WSD, R.Offset(, 1).Value, DestRow, DestColumn
            VA = Split(R.Value, "$")
            Select Case VA(1)
                Case 1
                    DocName = "document=" & "First-" & VA(0) & ".pdf"
                Case 2
                    DocName = "document=" & "Second-" & VA(0) & ".pdf"
                Case 3
                    DocName = "document=" & "Third-" & VA(0) & ".pdf"
            End Select
            LastSize = R.Value
        Next R
        
        WriteLine WSD, DocName, DestRow, DestColumn
        WriteLine WSD, "<enddoc>", DestRow, DestColumn
        
        'Write to text file.
        Set rng = .Range(.Cells(1, DestColumn), .Cells(.Rows.Count, DestColumn).End(xlUp))
        Open OutFile For Output Access Write As #1     ' Open text file for write
        For Each R In rng
            Print #1, R.Value                          ' Write to output file
        Next R
        Close #1                                       ' Close file.
        .Columns.AutoFit
    End With
    
    'Clean up
    On Error Resume Next
    Application.DisplayAlerts = False
    WSD.Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Application.ScreenUpdating = True
    
    MsgBox "New file created:" & vbCr & vbCr & OutFile, vbOKOnly Or vbInformation, Application.Name
End Sub
 
Upvote 0
Solution
I forgot to post this sub.
VBA Code: 
Private Sub WriteLine(DestWS As Worksheet, WriteStr As String, ByRef DestRow As Long, ByRef DestColumn As Long)
    DestWS.Cells(DestRow, DestColumn).Value = WriteStr
    DestRow = DestRow + 1
End Sub
 
Upvote 0
rlv01 said:
I forgot to post this sub.
VBA Code: 
Private Sub WriteLine(DestWS As Worksheet, WriteStr As String, ByRef DestRow As Long, ByRef DestColumn As Long)
    DestWS.Cells(DestRow, DestColumn).Value = WriteStr
    DestRow = DestRow + 1
End Sub
Click to expand...
Thanks, will give this a go. What do i do with this extra sub?
 
Upvote 0
rlv01 said:
One possibility
VBA Code: 
Sub MakeFile()
    Dim WB As Workbook
    Dim WS As Worksheet, WSD As Worksheet
    Dim rng As Range, R As Range, rng2 As Range
    Dim I As Long, LastRow As Long, DestRow As Long, DestColumn As Long
    Dim VA As Variant
    Dim DocName As String, LastSize As String, OutFile As String
    Dim inputfolder As String, outputfolder As String, reportfile As String, overwrite As String, padtoeven As String, author As String, title As String
   
    '===============User data ========================
    inputfolder = "C:\testfileinputlocation"
    'outputfolder = "C:\testfileoutputlocation"
    outputfolder = "C:\Users\223103252\Documents\TestFiles\"
    reportfile = "C:\testlogfilelocation\ProcessingLog.htm"
    overwrite = "no"
    padtoeven = "no"
    author = "Me"
    title = "filename"
   
    'Output File
    OutFile = outputfolder & "TestFile.Merge"
    '=================================================
    Application.ScreenUpdating = False
    Set WB = ActiveWorkbook
    Set WS = ActiveSheet
       
    'Add temporary worksheet and copy data to it.
    On Error Resume Next
    Application.DisplayAlerts = False
    ThisWorkbook.Worksheets("$TempSheet").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
   
    Set WSD = ThisWorkbook.Worksheets.Add
    WSD.Name = "$TempSheet"
   
    With WS
        Set rng2 = .Range("A2:D" & .Range("A" & .Rows.Count).End(xlUp).Row)
    End With
    rng2.Copy WSD.Range("A1") 'copy data to temporary worksheet
   
    'create formatted text
    With WSD
        Set rng = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
        For Each R In rng
            For I = 1 To 3
                R.Offset(0, I).Value = R.Offset(0, I).Value & "$" & I
            Next I
        Next R
       
        For I = 2 To 3
            LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
            rng.Offset(, I).Resize(, 1).Cut .Cells(LastRow + 1, 2)
            rng.Copy .Cells(LastRow + 1, 1)
        Next I
       
        'Sort
        .UsedRange.Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlYes
       
        Set rng = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
       
        DestRow = 1
        DestColumn = 5
       
        'Write header information
        WriteLine WSD, "inputfolder  = " & inputfolder, DestRow, DestColumn
        WriteLine WSD, "outputfolder  = " & outputfolder, DestRow, DestColumn
        WriteLine WSD, "reportfile  = " & reportfile, DestRow, DestColumn
        WriteLine WSD, "overwrite  = " & overwrite, DestRow, DestColumn
        WriteLine WSD, "padtoeven  = " & padtoeven, DestRow, DestColumn
        WriteLine WSD, "author  = " & author, DestRow, DestColumn
        WriteLine WSD, "title  = " & title, DestRow, DestColumn
       
        'Build formatted text
        LastSize = ""
        For Each R In rng
            R.Value = R.Value & "$" & Right(R.Offset(, 1).Value, 1)
            With R.Offset(, 1)
                VA = Split(.Value, "$")
                .Value = VA(0)
            End With
            If LastSize = "" Then
                WriteLine WSD, "<begindoc>", DestRow, DestColumn
            ElseIf R.Value <> LastSize Then
                WriteLine WSD, DocName, DestRow, DestColumn
                WriteLine WSD, "<enddoc>", DestRow, DestColumn
                WriteLine WSD, "<begindoc>", DestRow, DestColumn
            End If
            WriteLine WSD, R.Offset(, 1).Value, DestRow, DestColumn
            VA = Split(R.Value, "$")
            Select Case VA(1)
                Case 1
                    DocName = "document=" & "First-" & VA(0) & ".pdf"
                Case 2
                    DocName = "document=" & "Second-" & VA(0) & ".pdf"
                Case 3
                    DocName = "document=" & "Third-" & VA(0) & ".pdf"
            End Select
            LastSize = R.Value
        Next R
       
        WriteLine WSD, DocName, DestRow, DestColumn
        WriteLine WSD, "<enddoc>", DestRow, DestColumn
       
        'Write to text file.
        Set rng = .Range(.Cells(1, DestColumn), .Cells(.Rows.Count, DestColumn).End(xlUp))
        Open OutFile For Output Access Write As #1     ' Open text file for write
        For Each R In rng
            Print #1, R.Value                          ' Write to output file
        Next R
        Close #1                                       ' Close file.
        .Columns.AutoFit
    End With
   
    'Clean up
    On Error Resume Next
    Application.DisplayAlerts = False
    WSD.Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Application.ScreenUpdating = True
   
    MsgBox "New file created:" & vbCr & vbCr & OutFile, vbOKOnly Or vbInformation, Application.Name
End Sub
Click to expand...
Thanks heaps for this. It worked realy well. I added the extra sub at the bottom of the code and it seemed to run well. I just had to take out the extra spaces before and after the "=" for the file to run correctly in then plugin.
One more tiny tweak i need is to ignore or remove values that are zero for '"duplicate=0,fileA.pdf". I have discovered that the plugin software doenst except repeat0 and zero defaults to '1'.
 
Upvote 0
And also, if i wanted to change the DocName = to be a cell instead of the static text, what would i put in there instead? At the moment its
DocName = "document=" & "First-" & VA(0) & ".pdf"
I would want 'First' to be the cell B1, C1, D1 for example.
 
Upvote 0
Which worksheet the data cells B1, C1, D1 located on?
 
Upvote 0
rlv01 said:
Which worksheet the data cells B1, C1, D1 located on?
Click to expand...
Ideally i would like the tag for 'DocName=' to reference B1, C1 or D1 instead of a quote static text in the code. So if B1 was 'StoreA' then the code would have DocName = "document="B1" & "-" & VA(0) & ".pdf" (StoreA-Size.pdf). I can probably work around this.
The bigger issue i need to solve is to get rid of the lines or group if it has zero in the qty which is refered to as 'dupliicate0,filename.pdf'. I might even change the worksheet so it only contains the number and then this formula ads the 'duplicate'Cell,Filename' for example. but i need it to not include the entire line if cell contains '0' or less than 1 or something. I have also tried putting a an if statement into the B,C&D so 'if zero leave blank' but then i need this macro to ignore those lines. And then if the column had no content (all zeros) then not include that <begindoc> <enddoc> at all.
 
Upvote 0
Perhaps something like this (not tested):
VBA Code: 
            Select Case VA(1)
                Case 1
                    'DocName = "document=" & "First-" & VA(0) & ".pdf"
                    DocName = "document=" & WS.Range("B1").Value & "-" & VA(0) & ".pdf"
                Case 2
                    'DocName = "document=" & "Second-" & VA(0) & ".pdf"
                    DocName = "document=" & WS.Range("C1").Value & "-" & VA(0) & ".pdf"
                Case 3
                    'DocName = "document=" & "Third-" & VA(0) & ".pdf"
                    DocName = "document=" & WS.Range("D1").Value & "-" & VA(0) & ".pdf"
            End Select
 
Upvote 0
rlv01 said:
Perhaps something like this (not tested):
VBA Code: 
            Select Case VA(1)
                Case 1
                    'DocName = "document=" & "First-" & VA(0) & ".pdf"
                    DocName = "document=" & WS.Range("B1").Value & "-" & VA(0) & ".pdf"
                Case 2
                    'DocName = "document=" & "Second-" & VA(0) & ".pdf"
                    DocName = "document=" & WS.Range("C1").Value & "-" & VA(0) & ".pdf"
                Case 3
                    'DocName = "document=" & "Third-" & VA(0) & ".pdf"
                    DocName = "document=" & WS.Range("D1").Value & "-" & VA(0) & ".pdf"
            End Select
Click to expand...
this worked perfectly. Ive made lots of other small changes to test a few things and to learn how all the bits work.
for instance if i have more columns i change the range and also "For I = 1 To 3' to 1 to 4. But i cant work out which offset to change in the 'Create Formatted text' section if for example the data was in different columns such as C,D,E. The reason is if i wanted to not have the formula in the spreadsheet but instead in the VBA then the data would potentilally look like below. and i would want to use your VBA but include something along the lines of "duplicate" & WS.Range("C2") & "," & WS.Range("B2")
SizeFileheading1heading2Heading3
A4FileA.pdf
2​
4​
6​
A4FileB.pdf
3​
5​
7​
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question
Import new data from a text file based on certain field criteria.
2 3
Replies
23
Views
2K
maudedog
M
J
  • Question
VBA code error help, Issue with a loop. Issue with saving as pdfs with constantly changing names.
Replies
4
Views
919
John_w
J
A
  • Question
Page break issues when exporting to pdf from userform (VBA)
Replies
0
Views
716
auglocqnuk
A
D
  • Question
Editing a macro to include taking the file and opening an email
Replies
0
Views
707
Domroy
D
MrBart67
  • Solved
Save cell with "Today" function as a static date in new file
Replies
5
Views
2K
Joe4
Joe4

Forum statistics

Threads
1,215,176
Messages
6,123,470
Members
449,100
Latest member
sktz

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top