Copy range and save as a new text file

S

spycein

Board Regular
Joined
Mar 8, 2014
Messages
135
Office Version
  1. 365
Platform
  1. Windows
Hello everyone,
I looking for a VBA macro code which would copy a specified column range and save the same as text file.
For example, when i click the command button the code will copy the assigned range and ask for the path & file name to save the file.
Regards,
Shib
 
Sort by date Sort by votes
kennypete said:
This should work, letting you select columns, rows, or a range and saves the file as TXT (with tabs, but that could be changed). It does not copy anything or make new sheets, it just takes the selection (or trims it if whole columns or rows are selected to the last used cell in the column or row) and saves it. Note it requires the worksheet to be Sheet1.
VBA Code: 
Option Explicit
Sub SaveTXTselection()
   
    Dim strLine As String
    Dim intRow As Integer
    Dim booFirstCell As Boolean
    If Selection.Address = "$1:$1048576" Then Range(Sheet1.UsedRange.Address).Select ' if the whole sheet is selected then reduce it to the used range
    If UBound(Split(Selection.Address, "$")) = 2 Then
    ' whole column(s) or whole row(s) selected so we need to limit the output to the used range within the columns or rows
        If IsNumeric(Split(Split(Selection.Address, "$")(1), ":")(0)) Then
            ' whole row(s), so re-select to column A plus the extent of the used range's columns since the rest is empty
            Range("A" & Split(Selection.Address, "$")(1) & Split(Sheet1.UsedRange.Address, "$")(3) & Split(Selection.Address, "$")(2)).Select
        Else
            ' whole column(s), so re-select row 1 plus the extent of the used range's rows since the rest is empty
            Range(Split(Split(Selection.Address, "$")(1), ":")(0) & "1:" & Split(Selection.Address, "$")(2) & Split(Sheet1.UsedRange.Address, "$")(4)).Select
        End If
    End If
    intRow = Split(Split(Selection.Address, "$")(2), ":")(0)
    booFirstCell = True
   
    Dim varSaveAsTxt As Variant
    ' displays the save file dialog (file name only required, the .txt will be added)
    varSaveAsTxt = Application.GetSaveAsFilename(FileFilter:="Text (Tab delimited) (*.txt), *.txt")
    ' check to make sure the user hasn't pressed cancel
    If varSaveAsTxt = False Then Exit Sub
   
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim oFile As Object
    Set oFile = fso.CreateTextFile(varSaveAsTxt)
    Dim cell As Object
   
    ' Go through each selected cell and write it
    For Each cell In Selection
        If Split(cell.Address, "$")(2) > intRow Then
            oFile.writeline strLine
            intRow = intRow + 1
            strLine = cell.Value
        ElseIf booFirstCell Then
            strLine = cell.Value
            booFirstCell = False
        Else
            strLine = strLine & Chr(9) & cell.Value
        End If
    Next cell
    oFile.writeline strLine
    oFile.Close
    Set fso = Nothing
    Set oFile = Nothing
End Sub
I've tested it and it seems to handle things well. Give it a go.
Click to expand...
@kennypete
your above code is awesome, i was searching for the same solution for my needs. Above code is working fine , i just changed the codename of the sheet1 to matched my one. But instead of saving TEXT to a file , is it possible to just copy the range as Text on clipboard in same format as it shows in TXT file , so it can be pasted anywhere which required plain text .

Furthermore , can you help me to step by step to create a button on my main sheet which can trigger this macro and selected range will get copied to clipboard as text and ready to be pasted.
 
Upvote 0

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
kennypete said:
Sorry, no, I don't get it. How are you to know what range on Sheet 1 to output? You say:
"Could you please help to copy the data from more than once Column i.e. say Column "A to D" and CONCATENATE the value in a single line and save it as xml file.
For example if the value in Column A is 1A, Column B is 2A, Column C is 3A, Column D is 4A etc.. then my output result would be 1A2A3A4A."
...but not how you know you want A to D (rather than say A to G or just A and B)
Click to expand...
Dear @kennypete, really sorry for the confusion. The column names mentioned are just for the reference purpose as an example.
What i actually need to copy the data from Sheet 1 column A to Column L and save it as a xml file.
Hope this is helpful to understand the requirement.
Best Regards,
 
Upvote 0
bobby786 said:
@kennypete
your above code is awesome, i was searching for the same solution for my needs. Above code is working fine , i just changed the codename of the sheet1 to matched my one. But instead of saving TEXT to a file , is it possible to just copy the range as Text on clipboard in same format as it shows in TXT file , so it can be pasted anywhere which required plain text .

Furthermore , can you help me to step by step to create a button on my main sheet which can trigger this macro and selected range will get copied to clipboard as text and ready to be pasted.
Click to expand...
Okay, so I'm not sure that forking this to a separate thing is necessarily allowed, but since it is quite a short answer regarding the clipboard and selecting a range, here it is (code pared right back to the new use case):
VBA Code: 
Sub SelectedRangeToClipboard()
    rngSelected = Selection.Address
    For Each c In Range(rngSelected)
        strAll = strAll & c.Value
    Next c
    CreateObject("htmlfile").parentWindow.clipboardData.setData "text", strAll
End Sub
There are really complicated ways to copy to the clipboard, this and this, are sources examples, but this way (from the first link) seems the simplest.

Adding the macro to a button should be as simple as creating a new button:
1618118258421.png
Right clicking it, changing the text and assigning the macro to it
1618118307815.png


Here it is working...
1131178.gif
 
Upvote 0
spycein said:
Dear @kennypete, really sorry for the confusion. The column names mentioned are just for the reference purpose as an example.
What i actually need to copy the data from Sheet 1 column A to Column L and save it as a xml file.
Hope this is helpful to understand the requirement.
Best Regards,
Click to expand...
Okay @spycein, I have done this now going back to the earlier code and adjusting it to:
  • Change the TXT to XML since that seems to be what you want
  • Use the CurrentRegion of the cell A1 in Sheet1. This should pick up all of the cells from A-L columns and all of the contiguous content providing Column M is empty and you want all of the cells in columns A-L, which I infer you do, i.e. "copy the data from Sheet 1 column A to Column L"
  • Added some xml tags to make the output easier to read ("1A2A3A4A" wasn't) and openable with a browser, which I show below. If you don't want the tags, it should be easy for you to remove those from the code...
VBA Code: 
Sub Sheet1CurrentRegionToXML()
    Dim strStartingSheet As String
    Dim lngRow As Long
    Dim varSaveAsXML As Variant
    Dim rngA As Range
    Dim strRangeXML As String
     
    strStartingSheet = ActiveSheet.Name
    ' Turn off showing the screen
    Application.ScreenUpdating = False
    
    ' NB: Hardcoded to "Sheet1" tab as requested!
    Sheets("Sheet1").Visible = True
    Sheets("Sheet1").Select
    ' Now using CurrentRegion
    Set rngA = Range("A1").CurrentRegion
    
    ' Reselect the starting sheet before rehiding Sheet1
    Sheets(strStartingSheet).Select
    Sheets("Sheet1").Visible = False
    
    ' Turn on showing the screen
    Application.ScreenUpdating = True
    
    varSaveAsXML = Application.GetSaveAsFilename(FileFilter:="XML (XML data) (*.xml), *.xml")
    If varSaveAsXML = False Then Exit Sub
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim oFile As Object
    Set oFile = fso.CreateTextFile(varSaveAsXML)
    
    lngRow = 1
    oFile.writeline "<?xml version=""1.0""?>"
    oFile.writeline "<xml>"
    strRangeXML = "<row>"
    Dim rngCell As Range
    For Each rngCell In rngA
        If CInt(Split(rngCell.Address, "$")(2)) <> lngRow Then
            strRangeXML = strRangeXML & "</row>"
            lngRow = CInt(Split(rngCell.Address, "$")(2))
            oFile.writeline strRangeXML
            strRangeXML = "<row>"
        End If
        strRangeXML = strRangeXML & "<c>" & rngCell.Value & "</c>"
    Next rngCell
    oFile.writeline "</xml>"
    
    oFile.Close
    Set fso = Nothing
    Set oFile = Nothing

End Sub
My Sheet1 looks like this:
1618128973220.png

And the output to the XML file, with a Chromium browser:
1618129166041.png

And @bobby786 you may want to blend this approach with the solution I provided you above for adding the tags to the pasted selected region.
 
Upvote 0
kennypete said:
Okay, so I'm not sure that forking this to a separate thing is necessarily allowed, but since it is quite a short answer regarding the clipboard and selecting a range, here it is (code pared right back to the new use case):
VBA Code: 
Sub SelectedRangeToClipboard()
    rngSelected = Selection.Address
    For Each c In Range(rngSelected)
        strAll = strAll & c.Value
    Next c
    CreateObject("htmlfile").parentWindow.clipboardData.setData "text", strAll
End Sub
There are really complicated ways to copy to the clipboard, this and this, are sources examples, but this way (from the first link) seems the simplest.

Adding the macro to a button should be as simple as creating a new button:
View attachment 36419 Right clicking it, changing the text and assigning the macro to it View attachment 36420

Here it is working...
View attachment 36421
Click to expand...

I thought the issue is quite similar so i posted instead of making a new thread , sorry if it make you upset.

Thanks a lot for solution.
only thing the copied text is not delimited format like it was in your first code.
right now if i copy the text from excel to notepad it show me results like below without using macro , that's how i required it


ORD#1 40,000 S-30
ORD#1 40,000 S-33
ORD#1 20,000 PACE-100


from the below sheet data

ORD#140,000S-30
ORD#140,000S-33
ORD#120,000PACE-100



using macro i get the result like below to be exact.

ORD#140000S-30ORD#140000S-33ORD#120000PACE-100
 
Upvote 0
bobby786 said:
I thought the issue is quite similar so i posted instead of making a new thread , sorry if it make you upset.

Thanks a lot for solution.
only thing the copied text is not delimited format like it was in your first code.
right now if i copy the text from excel to notepad it show me results like below without using macro , that's how i required it


ORD#1 40,000 S-30
ORD#1 40,000 S-33
ORD#1 20,000 PACE-100


from the below sheet data

ORD#140,000S-30
ORD#140,000S-33
ORD#120,000PACE-100



using macro i get the result like below to be exact.

ORD#140000S-30ORD#140000S-33ORD#120000PACE-100
Click to expand...
There's been so many variants on the moving target that has been this thread @bobby786 I've lost count. In one of the prior posts I'd said you could blend the approaches together. Here's the tab delimited range selection paste modified/blended, with the main addition being ensuring that it can handle the range not starting at cell A1:
VBA Code: 
Sub SelectedRangeToClipboardTabs()
    rngSelected = Selection.Address
    'Column of first cell in the range
    lngCol = Split(Selection.Address, "$")(1)
    'Row of first cell in the range
    lngRow = Split(Split(Selection.Address, "$")(2), ":")(0)
    For Each c In Range(rngSelected)
        If CInt(Split(c.Address, "$")(2)) <> lngRow Then
            strAll = strAll & vbCrLf & c.Value
            lngRow = CInt(Split(c.Address, "$")(2))
        Else
            If Split(c.Address, "$")(1) = lngCol Then
                strAll = strAll & c.Value
            Else
                strAll = strAll & Chr(9) & c.Value
            End If
        End If
    Next c
    CreateObject("htmlfile").parentWindow.clipboardData.setData "text", strAll
End Sub
So that's with tabs delimiting (Chr(9)).
And in case the XML selection option is wanted I thought that may as well be thrown in too:
VBA Code: 
Sub SelectedRangeToClipboardXML()
    rngSelected = Selection.Address
    'Column of first cell in the range
    lngCol = Split(Selection.Address, "$")(1)
    'Row of first cell in the range
    lngRow = Split(Split(Selection.Address, "$")(2), ":")(0)
    strAll = "<?xml version=""1.0""?>" & vbCrLf & "<xml>" & vbCrLf
    For Each c In Range(rngSelected)
        If CInt(Split(c.Address, "$")(2)) <> lngRow Then
            strAll = strAll & "</row>" & vbCrLf & "<row><c>" & c.Value & "</c>"
            lngRow = CInt(Split(c.Address, "$")(2))
        Else
            If Split(c.Address, "$")(1) = lngCol Then
                strAll = strAll & "<row>" & "<c>" & c.Value & "</c>"
            Else
                strAll = strAll & "<c>" & c.Value & "</c>"
            End If
        End If
    Next c
    strAll = strAll & "</row>" & vbCrLf & "</xml>"
    CreateObject("htmlfile").parentWindow.clipboardData.setData "text", strAll
End Sub
Using your data and assigning to the button respectively, the outputs:
1618135436694.png
 
Upvote 0
kennypete said:
There's been so many variants on the moving target that has been this thread @bobby786 I've lost count. In one of the prior posts I'd said you could blend the approaches together. Here's the tab delimited range selection paste modified/blended, with the main addition being ensuring that it can handle the range not starting at cell A1:
VBA Code: 
Sub SelectedRangeToClipboardTabs()
    rngSelected = Selection.Address
    'Column of first cell in the range
    lngCol = Split(Selection.Address, "$")(1)
    'Row of first cell in the range
    lngRow = Split(Split(Selection.Address, "$")(2), ":")(0)
    For Each c In Range(rngSelected)
        If CInt(Split(c.Address, "$")(2)) <> lngRow Then
            strAll = strAll & vbCrLf & c.Value
            lngRow = CInt(Split(c.Address, "$")(2))
        Else
            If Split(c.Address, "$")(1) = lngCol Then
                strAll = strAll & c.Value
            Else
                strAll = strAll & Chr(9) & c.Value
            End If
        End If
    Next c
    CreateObject("htmlfile").parentWindow.clipboardData.setData "text", strAll
End Sub
So that's with tabs delimiting (Chr(9)).
And in case the XML selection option is wanted I thought that may as well be thrown in too:
VBA Code: 
Sub SelectedRangeToClipboardXML()
    rngSelected = Selection.Address
    'Column of first cell in the range
    lngCol = Split(Selection.Address, "$")(1)
    'Row of first cell in the range
    lngRow = Split(Split(Selection.Address, "$")(2), ":")(0)
    strAll = "<?xml version=""1.0""?>" & vbCrLf & "<xml>" & vbCrLf
    For Each c In Range(rngSelected)
        If CInt(Split(c.Address, "$")(2)) <> lngRow Then
            strAll = strAll & "</row>" & vbCrLf & "<row><c>" & c.Value & "</c>"
            lngRow = CInt(Split(c.Address, "$")(2))
        Else
            If Split(c.Address, "$")(1) = lngCol Then
                strAll = strAll & "<row>" & "<c>" & c.Value & "</c>"
            Else
                strAll = strAll & "<c>" & c.Value & "</c>"
            End If
        End If
    Next c
    strAll = strAll & "</row>" & vbCrLf & "</xml>"
    CreateObject("htmlfile").parentWindow.clipboardData.setData "text", strAll
End Sub
Using your data and assigning to the button respectively, the outputs:
View attachment 36433
Click to expand...

I cannot you thank you enough man , you are hero for excel. I am using the one without XML , and it works like charm .
 
Upvote 0
kennypete said:
Okay @spycein, I have done this now going back to the earlier code and adjusting it to:
  • Change the TXT to XML since that seems to be what you want
  • Use the CurrentRegion of the cell A1 in Sheet1. This should pick up all of the cells from A-L columns and all of the contiguous content providing Column M is empty and you want all of the cells in columns A-L, which I infer you do, i.e. "copy the data from Sheet 1 column A to Column L"
  • Added some xml tags to make the output easier to read ("1A2A3A4A" wasn't) and openable with a browser, which I show below. If you don't want the tags, it should be easy for you to remove those from the code...
VBA Code: 
Sub Sheet1CurrentRegionToXML()
    Dim strStartingSheet As String
    Dim lngRow As Long
    Dim varSaveAsXML As Variant
    Dim rngA As Range
    Dim strRangeXML As String
   
    strStartingSheet = ActiveSheet.Name
    ' Turn off showing the screen
    Application.ScreenUpdating = False
  
    ' NB: Hardcoded to "Sheet1" tab as requested!
    Sheets("Sheet1").Visible = True
    Sheets("Sheet1").Select
    ' Now using CurrentRegion
    Set rngA = Range("A1").CurrentRegion
  
    ' Reselect the starting sheet before rehiding Sheet1
    Sheets(strStartingSheet).Select
    Sheets("Sheet1").Visible = False
  
    ' Turn on showing the screen
    Application.ScreenUpdating = True
  
    varSaveAsXML = Application.GetSaveAsFilename(FileFilter:="XML (XML data) (*.xml), *.xml")
    If varSaveAsXML = False Then Exit Sub
  
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim oFile As Object
    Set oFile = fso.CreateTextFile(varSaveAsXML)
  
    lngRow = 1
    oFile.writeline "<?xml version=""1.0""?>"
    oFile.writeline "<xml>"
    strRangeXML = "<row>"
    Dim rngCell As Range
    For Each rngCell In rngA
        If CInt(Split(rngCell.Address, "$")(2)) <> lngRow Then
            strRangeXML = strRangeXML & "</row>"
            lngRow = CInt(Split(rngCell.Address, "$")(2))
            oFile.writeline strRangeXML
            strRangeXML = "<row>"
        End If
        strRangeXML = strRangeXML & "<c>" & rngCell.Value & "</c>"
    Next rngCell
    oFile.writeline "</xml>"
  
    oFile.Close
    Set fso = Nothing
    Set oFile = Nothing

End Sub
My Sheet1 looks like this:
View attachment 36431
And the output to the XML file, with a Chromium browser:
View attachment 36432
And @bobby786 you may want to blend this approach with the solution I provided you above for adding the tags to the pasted selected region.
Click to expand...
Dear @kennypete, Thank you so much for your help. Cannot thank you enough for this.
One last request, i have removed the xml tags since i only save the data in xml format. The only issue which i get when i save the data is it concatenate the each row data.

Following the updated code:

Sub Sheet1CurrentRegionToXML()
Dim strStartingSheet As String
Dim lngRow As Long
Dim varSaveAsXML As Variant
Dim rngA As Range
Dim strRangeXML As String

strStartingSheet = ActiveSheet.Name
' Turn off showing the screen
Application.ScreenUpdating = False

' NB: Hardcoded to "Sheet1" tab as requested!
Sheets("Sheet1").Visible = True
Sheets("Sheet1").Select
' Now using CurrentRegion
Set rngA = Range("A1").CurrentRegion

' Reselect the starting sheet before rehiding Sheet1
Sheets(strStartingSheet).Select
Sheets("Sheet1").Visible = False

' Turn on showing the screen
Application.ScreenUpdating = True

varSaveAsXML = Application.GetSaveAsFilename(FileFilter:="XML (XML data) (*.xml), *.xml")
If varSaveAsXML = False Then Exit Sub

Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oFile As Object
Set oFile = fso.CreateTextFile(varSaveAsXML)

Dim rngCell As Range
For Each rngCell In rngA
If CInt(Split(rngCell.Address, "$")(2)) <> lngRow Then
strRangeXML = strRangeXML
lngRow = CInt(Split(rngCell.Address, "$")(2))
oFile.writeline strRangeXML
End If
strRangeXML = strRangeXML & rngCell.Value
Next rngCell
oFile.writeline

oFile.Close
Set fso = Nothing
Set oFile = Nothing

End Sub


and the result which i get from the above code is as follows:

XML.PNG



But the result of the output data which i am looking is as follows

13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB

Many thanks once again
Best Regards,
 
Upvote 0
spycein said:
Dear @kennypete, Thank you so much for your help. Cannot thank you enough for this.
One last request, i have removed the xml tags since i only save the data in xml format. The only issue which i get when i save the data is it concatenate the each row data.

Following the updated code:

Sub Sheet1CurrentRegionToXML()
Dim strStartingSheet As String
Dim lngRow As Long
Dim varSaveAsXML As Variant
Dim rngA As Range
Dim strRangeXML As String

strStartingSheet = ActiveSheet.Name
' Turn off showing the screen
Application.ScreenUpdating = False

' NB: Hardcoded to "Sheet1" tab as requested!
Sheets("Sheet1").Visible = True
Sheets("Sheet1").Select
' Now using CurrentRegion
Set rngA = Range("A1").CurrentRegion

' Reselect the starting sheet before rehiding Sheet1
Sheets(strStartingSheet).Select
Sheets("Sheet1").Visible = False

' Turn on showing the screen
Application.ScreenUpdating = True

varSaveAsXML = Application.GetSaveAsFilename(FileFilter:="XML (XML data) (*.xml), *.xml")
If varSaveAsXML = False Then Exit Sub

Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oFile As Object
Set oFile = fso.CreateTextFile(varSaveAsXML)

Dim rngCell As Range
For Each rngCell In rngA
If CInt(Split(rngCell.Address, "$")(2)) <> lngRow Then
strRangeXML = strRangeXML
lngRow = CInt(Split(rngCell.Address, "$")(2))
oFile.writeline strRangeXML
End If
strRangeXML = strRangeXML & rngCell.Value
Next rngCell
oFile.writeline

oFile.Close
Set fso = Nothing
Set oFile = Nothing

End Sub


and the result which i get from the above code is as follows:

View attachment 36440


But the result of the output data which i am looking is as follows

13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB

Many thanks once again
Best Regards,
Click to expand...

Forgot to attach my source data sample which i need to save as xml format file

Data.PNG
 
Upvote 0
spycein said:
Dear @kennypete, Thank you so much for your help. Cannot thank you enough for this.
One last request, i have removed the xml tags since i only save the data in xml format. The only issue which i get when i save the data is it concatenate the each row data.

Following the updated code:

Sub Sheet1CurrentRegionToXML()
Dim strStartingSheet As String
Dim lngRow As Long
Dim varSaveAsXML As Variant
Dim rngA As Range
Dim strRangeXML As String

strStartingSheet = ActiveSheet.Name
' Turn off showing the screen
Application.ScreenUpdating = False

' NB: Hardcoded to "Sheet1" tab as requested!
Sheets("Sheet1").Visible = True
Sheets("Sheet1").Select
' Now using CurrentRegion
Set rngA = Range("A1").CurrentRegion

' Reselect the starting sheet before rehiding Sheet1
Sheets(strStartingSheet).Select
Sheets("Sheet1").Visible = False

' Turn on showing the screen
Application.ScreenUpdating = True

varSaveAsXML = Application.GetSaveAsFilename(FileFilter:="XML (XML data) (*.xml), *.xml")
If varSaveAsXML = False Then Exit Sub

Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oFile As Object
Set oFile = fso.CreateTextFile(varSaveAsXML)

Dim rngCell As Range
For Each rngCell In rngA
If CInt(Split(rngCell.Address, "$")(2)) <> lngRow Then
strRangeXML = strRangeXML
lngRow = CInt(Split(rngCell.Address, "$")(2))
oFile.writeline strRangeXML
End If
strRangeXML = strRangeXML & rngCell.Value
Next rngCell
oFile.writeline

oFile.Close
Set fso = Nothing
Set oFile = Nothing

End Sub


and the result which i get from the above code is as follows:

View attachment 36440


But the result of the output data which i am looking is as follows

13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB
13565981022ssGGMMOOSHIB

Many thanks once again
Best Regards,
Click to expand...
The following should do what you are after. The main thing that needed change was to reset strRangeXML to "" at each new 'row'.
VBA Code: 
Sub Sheet1CurrentRegionToXML2()
' XML2 solution
    
    Dim strStartingSheet As String
    Dim lngRow As Long
    Dim varSaveAsXML As Variant
    Dim rngA As Range
    Dim strRangeXML As String
     
    strStartingSheet = ActiveSheet.Name
    ' Turn off showing the screen
    Application.ScreenUpdating = False
    
    ' NB: Hardcoded to "Sheet1" tab as requested!
    Sheets("Sheet1").Visible = True
    Sheets("Sheet1").Select
    ' Now using CurrentRegion
    Set rngA = Range("A1").CurrentRegion
    
    ' Reselect the starting sheet before rehiding Sheet1
    Sheets(strStartingSheet).Select
    Sheets("Sheet1").Visible = False
    
    ' Turn on showing the screen
    Application.ScreenUpdating = True
    
    varSaveAsXML = Application.GetSaveAsFilename(FileFilter:="XML (XML data) (*.xml), *.xml")
    If varSaveAsXML = False Then Exit Sub
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim oFile As Object
    Set oFile = fso.CreateTextFile(varSaveAsXML)
    
    lngRow = 1
    Dim rngCell As Range
    For Each rngCell In rngA
        If CInt(Split(rngCell.Address, "$")(2)) <> lngRow Then
            lngRow = CInt(Split(rngCell.Address, "$")(2))
            ' Write the row and reset the strRangeXML variable
            oFile.writeline strRangeXML
            strRangeXML = ""
        End If
        strRangeXML = strRangeXML & rngCell.Value
    Next rngCell
    ' Write the last row
    oFile.writeline strRangeXML
    
    oFile.Close
    Set fso = Nothing
    Set oFile = Nothing

End Sub

Note it's hard to debug when all of your rows' data are identical. I tried it on my non-repetitive data and it works fine. Incidentally, I find it strange that all you are doing is saving the file as non-delimited text only, which is not XML. No matter, hopefully this closes this thread out finally.

I recommend in future posts you make it much clearer what you're trying to achieve overall + provide good source data examples to work with up front because this has been a very incremental thread, inching towards the final solution as the scope and requirements evolved. Take care.
 
Upvote 0
You must log in or register to reply here.

Similar threads

RichTom44
  • Question
Save as PDF format from the selected sheet
Replies
1
Views
139
DanteAmor
DanteAmor
T
  • Question
Automatically Copying Data To A New Workbook When Closing A Workbook
Replies
4
Views
317
Tmini
T
KlausW
  • Solved
Save location based on Cell value
Replies
3
Views
125
SunnyAlv
SunnyAlv
H
  • Question
Macro to save sheet as a CVS
Replies
5
Views
359
Joe4
Joe4
D
  • Solved
Vba excel protection save as and copying
Replies
8
Views
209
Wookiee
Wookiee

Forum statistics

Threads
1,221,531
Messages
6,160,364
Members
451,642
Latest member
mirofa

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