Copy range and save as a new text file

[spycein]

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

 

[spycein]

The following should do what you are after. The main thing that needed change was to reset strRangeXML to "" at each new 'row'.

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.

Thank you so much @kennypete, this is exactly what i wanted. I am really sorry for all confusion. Going forward i will make my requirements clear and provide the proper data set.
Best Regards,

 

[spycein]

Thank you so much @kennypete, this is exactly what i wanted. I am really sorry for all confusion. Going forward i will make my requirements clear and provide the proper data set.
Best Regards,

Dear @kennypete,
The below code works perfectly fine on my pc ( i am using Office 365 Business ) but getting run time error 13 on a different PC ( Office Version is Office 2016)

Kindly help on this.

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 = xlVeryHidden
   
    ' 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

Many thanks in advance.

Best Regards,

 

[kennypete]

This may be getting into IT/is versions support - you can Google/DDGo a search for causes of the error. My guess is that when you are running it from a different machine there are some cells that are containing #N/A or other values for some reason (perhaps due to linked data that is not available maybe). If so you would get the error. One link to consider: VBA Type Mismatch Error (Error 13)

 

[spycein]

This may be getting into IT/is versions support - you can Google/DDGo a search for causes of the error. My guess is that when you are running it from a different machine there are some cells that are containing #N/A or other values for some reason (perhaps due to linked data that is not available maybe). If so you would get the error. One link to consider: VBA Type Mismatch Error (Error 13)

Thank you so much @kennypete, i changed office version to O365 and its working now.