Is there a way to save as .txt after run a macro excel vba?

Question

.txt result wanted, from xml list columns

Good afternoon everyone,

I am having some difficulties in continuing with the code and I need your help.

Basically I have a file in .xml that it is opening as a table and I try to search only 3 columns that start with these fields:

NAME17 | POINTS_COUNT | Pt

In the "NAME17" fields, there are names that are repeated in many lines.

The goal is to always start each field listing of "NAME17" with

"START" and field name

"P" and number of existing coordinates for the field

after the last coordinate (field line) places

"END" (that is, between P 343 and "END" we will have 343 lines with such x, y and z coordinates)

and then, after placing the END P 343, put a new cycle, with the name of the 2 field of "NAME17" and put "START" and name of the next field again ... and repeat ...

"P" and number of coordinates that exist for the "RAIADOR" field and then all coordinates ...

and again "END RADIATOR" and new cycle with "P000", etc.

START EOP
P 343
2181.1800 673.4920 -864.6050
END EOP
START RAIADOR
P 354
2212.6300 660.3580 -886.8900
...
END RAIADOR
START...

Below the code already developed, in which I am having trouble continuing to create the reading cycles (for), inserting lines with the Starts / END and the P and No. and coordinates ... the final result should be recorded as a .txt separated by tabs for the case of the coordinates (x, y and z).

The .xml file and the final result in .txt(tabs) wanted is here: https://filesend.standardnotes.org/send/ROsr3jwXX5aXULYnNSrx#MjUzYjhjOGFkNjUyNjY5MTE1MmZm

Any Help?

` Sub MACRO_TXT_TAB() Application.DisplayAlerts = False

ActiveWindow.SmallScroll ToRight:=48

Range("Tabela1[[#Headers],[NAME17]]").EntireColumn.Select
Selection.Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
Sheets("Folha1").Select
Application.CutCopyMode = False


Range("Tabela1[[#Headers],[POINTS_COUNT]]").EntireColumn.Select
Selection.Copy
Sheets("Folha2").Select
Range("B1").Select
ActiveSheet.Paste
Sheets("Folha1").Select
Application.CutCopyMode = False

Range("Tabela1[[#Headers],[Pt]]").EntireColumn.Select
Selection.Copy
Sheets("Folha2").Select
Range("C1").Select
ActiveSheet.Paste
Range("A1:C1").Select
Application.CutCopyMode = False
Columns("A:A").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
Range("a1").Select

Columns("A:A").Select
Selection.Copy
Range("F1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Range("$F$1:$F$50000").RemoveDuplicates Columns:=1, Header:= _
    xlYes
Sheets.Add After:=ActiveSheet
ActiveCell.FormulaR1C1 = "=""START ""&Folha2!R2C6"
Range("A2").Select
ActiveCell.FormulaR1C1 = "=""P""&Folha2!RC[1]+""1"""
Range("A3").Select

Sheets("Folha2").Select
Sheets("Folha2").Activate


Dim i, NLinhas2, Nlinhas3 As Integer
Dim nome As String


i = 0
NLinhas2 = Range("A65536").End(xlUp).Row
Nlinhas3 = 3

For i = 1 To NLinhas2

nome = Range("A2").Value 'coloca primeiro nome
If (nome) = Range("A" & i + 1) Then
Worksheets("Folha3").Cells(Nlinhas3, 1) = Worksheets("Folha2").Cells(i + 1, 3)
Else: Exit For
End If

Nlinhas3 = Nlinhas3 + 1

Next i


Application.DisplayAlerts = True
End Sub

`

this is the values, i'm run the original code in sheet 1 of original .xml file

could be the error this variable m?

It's continues to stop with a error in this line
{ Err.Raise vbObjectError + 1, "LoadData", "Invalid data format in cell " & _ .Cells(dataRange.Rows(1).row + row - 1, dataRange.Columns(1).Column + lastCol - 1).Address }

and no variable m and definition next

This is my file with diferent columns for data, with start in row 10

This is the last result with the modification code

It continuous to do the error in xval = m(0).SubMatches(0) - Type mismatch

'Option Explicit

' Function reads the given range and returns a dictionary.
' key is the first column of the selected range,
' value is a list of arrays (x, y, z).
Function LoadData(ByVal dataRange As Range) As Dictionary

Dim dict As Dictionary
Dim re As VBScript_RegExp_55.RegExp
Dim m As VBScript_RegExp_55.MatchCollection
Dim rawData As Variant
Dim lastCol As Long
Dim row As Long
Dim name17 As String
Dim coordinateCell As Range
Dim coordinates As String
Dim xval As Double
Dim yval As Double
Dim zval As Double

' Initialize dictionary.
Set dict = New Dictionary

' Initialize regular expression.
Set re = New RegExp
re.Pattern = "^\s*X=(-?\d+\.\d+)\s+Y=(-?\d+\.\d+)\s+Z=(-?\d+\.\d+)\s*$"

' Get the coordinates from the last column of the data range.
lastCol = dataRange.Columns.Count

' Copy selected range to array for faster processing.
rawData = dataRange.Value
   
' For each row in data array...
For row = LBound(rawData, 1) To UBound(rawData, 1)
    
    ' Get name17 from the first column of the data range.
    name17 = rawData(row, 1)
    
    ' Add name17 to dictionary if it doesn't already exist.
    If Not dict.Exists(name17) Then
        dict.Add name17, New Collection
    End If

    ' Get the coordinates from the last column of the data range.
    coordinates = rawData(row, lastCol)
    
    ' Use regular expression to parse coordinates.
    If Not re.Test(coordinates) Then
        With dataRange.Worksheet
            Set coordinateCell = .Cells(dataRange.Rows(1).row + row - 1, _
                dataRange.Columns(1).Column + lastCol - 1)
        End With
        Err.Raise vbObjectError + 1, "LoadData", "Invalid data format '" & _
            coordinates & "' in cell " & coordinateCell.Address
    End If

    Set m = re.Execute(coordinates)
    xval = m(0).SubMatches(0)
    yval = m(0).SubMatches(1)
    zval = m(0).SubMatches(2)
    
    ' Add data value.
    dict(name17).Add Array(xval, yval, zval)
    
Next row

Set LoadData = dict

End Function '

and the test sub:

' Sub Test()

Dim dataRange As Range
Dim data As Dictionary
Dim name17 As Variant
Dim val As Variant

Set dataRange = Worksheets("Sheet1").Range("BG10:BV365")
'Set dataRange = Range("BG10:BV365")
Set data = LoadData(dataRange)
For Each name17 In data.Keys
    Debug.Print "START " & name17
    Debug.Print "P " & data(name17).Count
    For Each val In data(name17)
        Debug.Print val(0), val(1), val(2)
    Next val
    Debug.Print "END " & name17
Next name17

End Sub ' 

---

This is my code, i compile, and nothing happens, i still get the error in m(0) file. But if i change the coordinate X=2181.18 Y=673.492 Z=-864.605 to decimal: X=2181,18 Y=673,492 Z=-864,605 the error is in the line:

            Err.Raise vbObjectError + 1, "LoadData", "Invalid data format '" & _
            coordinates & "' in cell " & coordinateCell.Address

with the message: "Invalid data format (x,y,z) in cell $BV$10 "

Answer 1

This function reads the selected data range and returns an dictionary of names and parsed coordinate values.

Option Explicit

' Function reads the given range and returns a dictionary.
'   key is the first column of the selected range,
'   value is a list of arrays (x, y, z).
Function LoadData(ByVal dataRange As Range) As Dictionary

    Dim dict As Dictionary
    Dim re As VBScript_RegExp_55.RegExp
    Dim m As VBScript_RegExp_55.MatchCollection
    Dim rawData As Variant
    Dim lastCol As Long
    Dim row As Long
    Dim name17 As String
    Dim coordinateCell As Range
    Dim coordinates As String
    Dim xval As Double
    Dim yval As Double
    Dim zval As Double
    
    ' Initialize dictionary.
    Set dict = New Dictionary
    
    ' Initialize regular expression.
    Set re = New RegExp
    re.Pattern = "^\s*X=(-?\d+\.\d+)\s+Y=(-?\d+\.\d+)\s+Z=(-?\d+\.\d+)\s*$"
    
    ' Get the coordinates from the last column of the data range.
    lastCol = dataRange.Columns.Count
    
    ' Copy selected range to array for faster processing.
    rawData = dataRange.Value
       
    ' For each row in data array...
    For row = LBound(rawData, 1) To UBound(rawData, 1)
        
        ' Get name17 from the first column of the data range.
        name17 = rawData(row, 1)
        
        ' Add name17 to dictionary if it doesn't already exist.
        If Not dict.Exists(name17) Then
            dict.Add name17, New Collection
        End If
    
        ' Get the coordinates from the last column of the data range.
        coordinates = rawData(row, lastCol)
        
        ' Use regular expression to parse coordinates.
        If Not re.Test(coordinates) Then
            With dataRange.Worksheet
                Set coordinateCell = .Cells(dataRange.Rows(1).row + row - 1, _
                    dataRange.Columns(1).Column + lastCol - 1)
            End With
            Err.Raise vbObjectError + 1, "LoadData", "Invalid data format '" & _
                coordinates & "' in cell " & coordinateCell.Address
        End If

        Set m = re.Execute(coordinates)
        xval = m(0).SubMatches(0)
        yval = m(0).SubMatches(1)
        zval = m(0).SubMatches(2)
        
        ' Add data value.
        dict(name17).Add Array(xval, yval, zval)
        
    Next row
    
    Set LoadData = dict

End Function

This is how you would use it.

Sub Test()

    Dim dataRange As Range
    Dim data As Dictionary
    Dim name17 As Variant
    Dim val As Variant
    
    Set dataRange = Worksheet("Sheet1").Range("BG10:BV365")
    Set data = LoadData(dataRange)
    For Each name17 In data.Keys
        Debug.Print "START " & name17
        Debug.Print "P " & data(name17).Count
        For Each val In data(name17)
            Debug.Print val(0), val(1), val(2)
        Next val
        Debug.Print "END " & name17
    Next name17
    
End Sub

You will need to add references to the following libraries to make this work.

This is the result