VB Script for txt file parser, sort and export.

[R2dical]

Hi VB experts! (First post)

I have a large number of data files for a game, they are text files but have various extensions (like .weapon or .shipsection). These files contain a code hook and a integer,boolean or string separated by a space and or tab. There are a set list of available code hook variables (around 250) but each text file only specifies relevant ones to be changed from default. I would like to have 2 Macros, one to import existing txt files and one to export. The goal is to be able to have a database to manage these individual txt files without editing them manually.

Here is one of the .txt files

weapon
{
    name            'PD Interceptor'
    weaponclass        pdmissile
    weaponfamily        missile
    model1            ""                // insert barrel model for tiny mounts here if we get them
    model2            barrel_pdmissile.X        // NOTE: model2 for tiny pd weapons in small mounts
    requires        WEP_PDtech
    requires        DRV_Ints
    turretsize        tiny
    cost            4000
    turretclass        standard
    burst_volleys        1
    volley_period        .2
    recharge_time        8
    muzzle_sound        Sounds/Weapons/mis_interceptor_pd_muzzle.wav
    muzzle_sound_minrange    60
    muzzle_effect        effects/Missile_dfire_muzzle.effect
    muzzle_speed        100
    solution_tolerance    360
    icon_file        GUI/WeaponIcons_Warhead.tga
    icon_rect        "128 192 64 64"

    range            700
    range_planet        0    // Same as 'range' because missile has a fixed time-to-live. (range should be a bit less than [netforcelimits] speed x ttl)
    
    fc_requires_los                true
    fc_requires_inrange            true
    fc_requires_enemycolony            false
    fc_manual_target            false
    fc_manual_toggle            false
    fc_manual_launch            false
    fc_controllable                false
    fc_holdsfire                false
    blindfire                 false
    pinpoint                 false

    missile
    {
        tracking         1
        pd             1
        warhead_dam_scale     1 // add standard missile warhead damage modifier
    
        impact_decal        decals/WeaponHit.decal
        impact_decal_width     .5
        impact_decal_height     .5
        impact_decal_depth     .1

        beam_origin        -3
        beam_length        5.5

        impact_sound        Sounds/Weapons/mis_interceptor_pd_impact.wav
        impact_sound_minrange    200
        impact_effect        effects/mis_tarka_dfire_impact.effect
        area_impact_effect     "effects/collide_asteroid.effect"
        Planet_Impact_Effect    "effects/mis_pd_impact.effect"

        thrust_sound        Sounds/Weapons/mis_missile_travel.wav
        
        speed             350
        seek_attenuation     11    // Higher number = tighter turns/faster accel

        ttl            2.5
        model            missile.X
        health            15
        dam            60
        dam_radius        0
        mass            25
        thrust_effect        effects/Missile_small_trail.effect
        thrust_node        EffectNode
        dumbfire_period        0.5

        dam_pop        0
        dam_infra    0
        dam_terra    0
    }

    rating_frate    3
    rating_dam    3
    rating_acc    10
    rating_range    7

    dam_est        60
}

In excel I have a page intended to be a export template containing all the existing code hook types. I want to create another page using the importer with columns for every hook instance and rows for each txt file instance. Column 1 must be the txt file name and the rest of the columns populated only if the hook is present and with the value associated. Export would work by reading values off the database for each row into the template page if they exist for each column and create a text file using tab as delimiter.

Here is the scripts I have so far:

Import:

' ---------------------- Directory Choosing Helper Functions -----------------------
' Excel and VBA do not provide any convenient directory chooser or file chooser
' dialogs, but these functions will provide a reference to a system DLL
' with the necessary capabilities
Private Type BROWSEINFO ' used by the function GetFolderNameB
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Function GetFolderNameB(Msg As String) As String
' returns the name of the folder selected by the user
Dim bInfo As BROWSEINFO, path As String, r As Long
Dim X As Long, pos As Integer
    bInfo.pidlRoot = 0& ' Root folder = Desktop
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
        ' the dialog title
    Else
        bInfo.lpszTitle = Msg ' the dialog title
    End If
    bInfo.ulFlags = &H1 ' Type of directory to return
    X = SHBrowseForFolder(bInfo) ' display the dialog
    ' Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal X, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetFolderNameB = Left(path, pos - 1)
    Else
        GetFolderNameB = ""
    End If
End Function
'---------------------- END Directory Chooser Helper Functions ----------------------


Sub ImportManyTXTIntoColumns()
'Author:    Jerry Beaucaire
'Date:      2/24/2012
'Summary:   From a specific folder, import TXT files 1 file per column

Dim fPath As String, fTXT As String

Application.ScreenUpdating = False
                                        
fPath = GetFolderNameB("Choose the folder to import .weapon files from:")
If fPath = "" Then
    MsgBox ("You didn't choose an import directory. Nothing will be imported.")
    Exit Sub
End If
Set wsTrgt = ThisWorkbook.Sheets.Add    'new sheet for incoming data
NC = 1                                  'first column for data

fTXT = Dir(fPath & "*.txt")          'get first filename

    Do While Len(fTXT) > 0              'process one at a time
                                        'open the file in Excel
        Workbooks.OpenText fPath & fTXT, Origin:=437
                                        'put the filename in the target column
        wsTrgt.Cells(1, NC) = ActiveSheet.Name
                                        'copy column A to new sheet
        Range("A:A").SpecialCells(xlConstants).Copy wsTrgt.Cells(2, NC)

        ActiveWorkbook.Close False      'close the source file
        NC = NC + 1                     'next column
        fTXT = Dir                      'next file
    Loop
   
Application.ScreenUpdating = True
End Sub

Export:

' ---------------------- Directory Choosing Helper Functions -----------------------
' Excel and VBA do not provide any convenient directory chooser or file chooser
' dialogs, but these functions will provide a reference to a system DLL
' with the necessary capabilities
Private Type BROWSEINFO ' used by the function GetFolderName
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Function GetFolderName(Msg As String) As String
' returns the name of the folder selected by the user
Dim bInfo As BROWSEINFO, path As String, r As Long
Dim X As Long, pos As Integer
    bInfo.pidlRoot = 0& ' Root folder = Desktop
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
        ' the dialog title
    Else
        bInfo.lpszTitle = Msg ' the dialog title
    End If
    bInfo.ulFlags = &H1 ' Type of directory to return
    X = SHBrowseForFolder(bInfo) ' display the dialog
    ' Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal X, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetFolderName = Left(path, pos - 1)
    Else
        GetFolderName = ""
    End If
End Function
'---------------------- END Directory Chooser Helper Functions ----------------------

Public Sub DoTheExport()
Dim FName As Variant
Dim Sep As String
Dim wsSheet As Worksheet
Dim nFileNum As Integer
Dim csvPath As String


Sep = " "
                 'csvPath = InputBox("Enter the full path to export .weapon files to: ")
csvPath = GetFolderName("Choose the folder to export CSV files to:")
If csvPath = "" Then
    MsgBox ("You didn't choose an export directory. Nothing will be exported.")
    Exit Sub
End If

For Each wsSheet In Worksheets
wsSheet.Activate
nFileNum = FreeFile
Open csvPath & "\" & _
  wsSheet.Name & ".shipsection" For Output As #nFileNum
ExportToTextFile CStr(nFileNum), Sep, False
Close nFileNum
Next wsSheet

End Sub



Public Sub ExportToTextFile(nFileNum As Integer, _
Sep As String, SelectionOnly As Boolean)

Dim WholeLine As String
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String

Application.ScreenUpdating = False
On Error GoTo EndMacro:

If SelectionOnly = True Then
With Selection
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
Else
With ActiveSheet.UsedRange
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
End If

For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = ""
Else
CellValue = Cells(RowNdx, ColNdx).Value
End If
WholeLine = WholeLine & CellValue & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #nFileNum, WholeLine
Next RowNdx

EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True

End Sub

I used a script with directory navigation but the import one does not work properly...Is this too much to ask of macros?

Thanks in advance for any responses

 

[Garry2Rs]

As far as I can tell.., you're putting each text file into its own column. Is this correct?

Also, you open/close each file in Excel rather than read the file contents! Way too much overhead for me!! Why not just read the file into an array (without opening it in Excel) and dump the array into the target sheet where you want to put it?

Also, you read/write back to a text file one row/line at a time! Again, way too much overhead for me!! Why not dump the sheet contents into an array and write to file in a single step?

You can do all of this using standard VB[A] I/O functions/methods. If you explain clearly what's not working with your import procedure it would help toward a good solution. Explain clearly the expected result for importing each file...

 

[R2dical]

Hi Garry2Rs, Thanks for your reply.

I should have mentioned that I am new to Macros and VB and fairly new to coding in general, therefore my current efforts are limited to hacking bits of other scripts together...great learning though!

Once again the goal is to read a directory full of these text files and use the contained data to populate a table with each file being a row and only inputing values in columns if the data is present. Then I would like to export the table into a directory working this process in reverse but also using a template sheet populated from the table using only relevant columns, for each row and subsequent export.

From the little I understand of arrays it sounds like that would be the best way to populate the table on import, I managed to get a workable series of steps but 500 files takes about 20 mins and the total is around 3000 files...

My approach is now this, with a script for each step:

Import each text file into a separate sheet in a new workbook, used as intermediate storage.

' ---------------------- Directory Choosing Helper Functions -----------------------
' Excel and VBA do not provide any convenient directory chooser or file chooser
' dialogs, but these functions will provide a reference to a system DLL
' with the necessary capabilities
Private Type BROWSEINFO ' used by the function GetFolderNameImport
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Function GetFolderNameImport(Msg As String) As String
' returns the name of the folder selected by the user
Dim bInfo As BROWSEINFO, Path As String, r As Long
Dim X As Long, pos As Integer
    bInfo.pidlRoot = 0& ' Root folder = Desktop
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
        ' the dialog title
    Else
        bInfo.lpszTitle = Msg ' the dialog title
    End If
    bInfo.ulFlags = &H1 ' Type of directory to return
    X = SHBrowseForFolder(bInfo) ' display the dialog
    ' Parse the result
    Path = Space$(512)
    r = SHGetPathFromIDList(ByVal X, ByVal Path)
    If r Then
        pos = InStr(Path, Chr$(0))
        GetFolderNameImport = Left(Path, pos - 1) & "\"
    Else
        GetFolderNameImport = ""
    End If
End Function
'---------------------- END Directory Chooser Helper Functions ----------------------


Sub Import()

Dim wbPath As String                    'create new workbook

wbPath = ThisWorkbook.Path

strNewWBName = wbPath & "\" & "Import Database"
Workbooks.Add
ActiveWorkbook.SaveAs strNewWBName

Dim fPath As String, fTXT As String

Application.ScreenUpdating = False
                                        'path to files,
fPath = GetFolderNameImport("Choose the folder to import .weapon files from:")
If fPath = "" Then
    MsgBox ("You didn't choose an import directory. Nothing will be imported.")
    Exit Sub
End If
    
fTXT = Dir(fPath & "*.weapon")          'get first filename

    Do While Len(fTXT) > 0              'process one at a time
    
    ActiveWorkbook.Worksheets.Add       'import text
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" + fPath & fTXT, Destination:=Range("$A$1"))
        .Name = fTXT
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = True
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(9, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
                                        'find and replace
        Cells.Replace What:="'", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    
                                        'name worksheet
        Range("A1").Value = "File Name"
        Range("B1").Value = fTXT
            Cells.Replace What:=".weapon", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
        fTXT = Dir                      'next file
    Loop
   
   
Application.DisplayAlerts = False
ActiveWorkbook.Save
    Worksheets("Sheet1").Delete
    Worksheets("Sheet2").Delete
    Worksheets("Sheet3").Delete
Application.DisplayAlerts = True
ActiveWorkbook.Close SaveChanges:=True
Application.ScreenUpdating = True

End Sub

Optimize the import workbook, I had to transpose each sheet to get my column searching and combine to work.

Sub OptimizeDatabase()

    'open database
    On Error GoTo ErrorHandler
    Workbooks(ThisWorkbook.Path & "\" & "Import Database.xlsx").Activate

    Dim LR As Long, Rw As Long, Delim As String

'Copy script here:

    Exit Sub
        
ErrorHandler:
          Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "Import Database.xlsx"
    
    Dim wk As Worksheet
    [C1] = True
    Delim = ","
   
    Application.ScreenUpdating = False
    
    For Each wk In ActiveWorkbook.Worksheets
        wk.Activate
    
             'find and replace
            Cells.Replace What:="{", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        
            Cells.Replace What:="}", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        
        'Combine multiple rows
    LR = Range("A" & Rows.Count).End(xlUp).Row
   
    Range("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortTextAsNumbers
   
    With Range("C2:C" & LR)
        .Formula = "=IF(A2=A3,IF($C$1,IF(ISNUMBER(SEARCH(B2,C3)), C3, C3 & """ & _
                        Delim & """ & B2), C3 & """ & Delim & """ & B2), B2)"
        .Value = .Value
        .Copy Range("B2")
        .Formula = "=A2=A1"
    End With
   
    Range("C:C").AutoFilter
    Range("C:C").AutoFilter 1, True
    Range("C2:C" & LR).EntireRow.Delete xlShiftUp
    Range("C:C").AutoFilter
    Range("C:C").ClearContents
    Columns.AutoFit
    
    'Transpose
        Range("A1:B200").Select
    Selection.Copy
    Range("C1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Columns("A:B").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft

    Next wk

    ActiveWorkbook.Close SaveChanges:=True
    
    Application.ScreenUpdating = True
          
    End Sub

Copy the data on each sheet in the import workbook into the columns specified in the destination sheet.

Option Explicit

Sub ConsolidateRandomColumns()
'Jerry Beaucaire   6/23/2010
'Open a source file and copy all the data from all sheets
'into this workbook matching the column headers in this workbook
Dim wsData  As Worksheet
Dim wsCons  As Worksheet
Dim wbSrc   As Workbook
Dim Path    As String
Dim Col     As Long
Dim NumCols As Long
Dim ColFnd  As Long
Dim LastRow As Long
Dim NextRow As Long
Application.ScreenUpdating = False

Path = ThisWorkbook.Path

'Setup - Report sheet
    Set wsCons = ThisWorkbook.Sheets("Database")
    NumCols = wsCons.Range("1:1").SpecialCells(xlConstants).Columns.Count
    NextRow = wsCons.Range("A" & Rows.Count).End(xlUp).Row + 1

'Open the source data workbook
    Set wbSrc = Workbooks.Open(Path & "\" & "Import Database.xlsx")
    On Error Resume Next

'Loop each sheet and collect data from matching columns
    For Each wsData In ActiveWorkbook.Worksheets 'wbSrc.Worksheets
    wsData.Activate
    
        LastRow = wsData.Cells.Find("*", wsData.Cells(Rows.Count, Columns.Count), _
            SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        For Col = 1 To NumCols
            ColFnd = wsData.Range("1:1").Find(wsCons.Cells(1, Col).Text, _
                wsData.Cells(1, Columns.Count), xlValues, xlWhole, _
                SearchOrder:=xlByColumns, SearchDirection:=xlNext).Column
            If ColFnd > 0 Then
                wsData.Range(wsData.Cells(2, ColFnd), wsData.Cells(LastRow, ColFnd)) _
                    .Copy wsCons.Cells(NextRow, Col)
                ColFnd = 0
            End If
        Next Col
        NextRow = wsCons.Range("A" & Rows.Count).End(xlUp).Row + 1
    Next wsData
   
'Cleanup
    wbSrc.Close False
    Set wsCons = Nothing
    Set wbSrc = Nothing
    Application.ScreenUpdating = True
End Sub

So these steps kind of work, but take a very long time. Also columns are only populated up to "BH" after that one no more.

Appologies for jumping around so much with my approach, I know its easier to help with a specific issue and code, but I am still learning and don't know the most efficient way to do this.

Here is the current spreadsheet: Weapons Database.xlsm
Here is my group of test files to import: wep.zip

 

[Garry2Rs]

Your online storage is expecting me to download/install software before I can download your files. Not gonna happen! Please use another server...

 

[R2dical]

Hmm, sorry about that, looks like it does its own thing for certain extensions.

Here is a zip of the file, which should go to download: Weapons Database.zip

I managed to solve the database build issue where it stops at a certain column, but the import times are a big issue and I fear my approach for export will be similar.

 

[Garry2Rs]

Actually, please accept my apology! My bad for not looking closer, as I missed where the download link to your file was.
I have all files now and will look at this shortly...

 

[R2dical]

No problem and thanks for taking a look.

I thought I'd mention that I discovered that some of those test txt files have been edited using incorrect delimiter info (space instead of tab). Our engine parser handles that fine but my import script deletes some info due to this. I have a workaround to solve this so it can be ignored for this, incase you see the effects.

For interest sake I used notepad++ and some find and replace steps to correct the formating in the txt files but preserve the space seperation where it IS necessary:

START

 
#

("[0-9]{1,3})#([0-9]{1,3})#([0-9]{1,3})#([0-9]{1,3}")
\1 \2 \3 \4

("[0-9]{1,3})#([0-9]{1,3})#([0-9]{1,3}")
\1 \2 \3

("[0-9]{1,3})#([0-9]{1,3}")
\1 \2

([A-Z]{1,20})#([A-Z]{1,20})
/1 /2

([A-Z]{1,20})#([A-Z]{1,20})
/1 /2

#
    

/END

I look forward to your advice!

 

[Garry2Rs]

That looks nothing like the files I downloaded. Did you upload the correct files?

 

[R2dical]

Yes the files I posted are correct. Sorry, the above code block is 5 find and replace steps to convert space delimited text file to tab while preserving "quote" included text. The text files I would like to import look like the one in my first post (first code block) and are in the wep.zip file.

To see what I am trying to do;
Open Weapons Database.xlsm
On the "Main" tab run Macro button "Import .weapon Files", will prompt for a directory. One with a couple of the .weapon files from wep.zip will probably be best, doing all 500+ takes a while (and is my problem). This will create a new workbook also: "Import Database".
Then run Optimize Database.
Then Build Database, this is the longest step and I'm hoping the best candidate to improve.
The "Database" tab in the original workbook will now be populated with the data in the .weapon files and (other than the errors due to the delimiter issue in my previous post) is fine for my needs.

Final step would be to figure out how to export.

 

[Garry2Rs]

Thanks! I will press on with that info...