Extract a part of Text file

**parasbshah** · 07-14-2011, 03:55 PM

Hello !!!

I have a text file that is generated by another program. Below is the snapshot of the file format:

*********************************** START ****************************************
SKIRT DATA-MAJOR SIDE
Z PROFILE
14.0000 0.1678
15.0000 0.1591
16.0000 0.1437
17.0000 0.1264
********************************************************************************
$-------------- FLARE ENGINE file cards ------------
$******************* PROFILE # 1 ***************
SKCORD 1
ASPF USER
NASPU 28
ASPUL -14.00E-03 -15.00E-03 -16.00E-03 -17.00E-03 -18.00E-03 +
-19.00E-03 -20.00E-03 -21.00E-03 -22.00E-03 -23.00E-03 +
-24.00E-03 -25.00E-03 -26.00E-03 -27.00E-03 -28.00E-03 +
-29.00E-03 -30.00E-03 -31.00E-03 -32.00E-03 -33.00E-03 +
-34.00E-03 -35.00E-03 -36.00E-03 -37.00E-03 -38.00E-03 +
-39.00E-03 -40.00E-03 -41.00E-03
ASPUC 0.08391E-03 0.07956E-03 0.07184E-03 0.06320E-03 0.05482E-03 +
0.04725E-03 0.03975E-03 0.03225E-03 0.02547E-03 0.02045E-03 +
0.01563E-03 0.01120E-03 0.00749E-03 0.00467E-03 0.00265E-03 +
0.00126E-03 0.00050E-03 0.00003E-03 0.00000E-03 0.00000E-03 +
0.00000E-03 0.00000E-03 0.00030E-03 0.00130E-03 0.00550E-03 +
0.01254E-03 0.02173E-03 0.03337E-03
$--------------------------------------------------
ASPFN SAME
$--------------------------------------------------
-14.0000 0.0839
-15.0000 0.0796
-16.0000 0.0718
-17.0000 0.0632
-18.0000 0.0548
*********************************** END ****************************************

I would like to extract a part of this file and dump it in a different text file. The part of the file that needs to be extracted starts from the line "SKCORD 1" until the line "ASPFN SAME".
What would be the easiest way to program this using VBA?

Thanks

Paras

**tigeravatar** · 07-14-2011, 06:11 PM

Paras,

Assuming you wanted the text to be put into Cell A1 and down of the activesheet (and only in column A), you can use the following code:

Sub ExtractTextMacro_for_Paras()
    
    Dim strPath As String: strPath = Application.GetOpenFilename("Text Files (*.txt), *.txt)")
    If strPath = "False" Then Exit Sub
    Application.ScreenUpdating = False
    
    Dim DataStart As Boolean: DataStart = False
    Dim DataEnd As Boolean:   DataEnd = False
    Dim strLine As String
    Dim arrLine() As String, LineIndex As Long
    
    Close #1: Open strPath For Input As #1
    While Not EOF(1) And DataEnd = False
        Line Input #1, strLine
        If strLine = "SKCORD 1" Then DataStart = True
        If strLine = "ASPFN SAME" Then DataEnd = True
        If DataStart = True And DataEnd = False Then
            LineIndex = LineIndex + 1
            ReDim Preserve arrLine(1 To LineIndex)
            arrLine(LineIndex) = strLine
        End If
    Wend
    Close #1
    
    If LineIndex > 1 Then
        ReDim Preserve arrLine(1 To LineIndex - 1)
        ActiveSheet.[A1].Resize(LineIndex - 1, 1).Value = WorksheetFunction.Transpose(arrLine)
    End If
    Application.ScreenUpdating = True
    
End Sub

Hope that helps,
~tigeravatar

**parasbshah** · 07-15-2011, 02:55 PM

Originally Posted by tigeravatar

Paras,

Assuming you wanted the text to be put into Cell A1 and down of the activesheet (and only in column A), you can use the following code:

Sub ExtractTextMacro_for_Paras()
    
    Dim strPath As String: strPath = Application.GetOpenFilename("Text Files (*.txt), *.txt)")
    If strPath = "False" Then Exit Sub
    Application.ScreenUpdating = False
    
    Dim DataStart As Boolean: DataStart = False
    Dim DataEnd As Boolean:   DataEnd = False
    Dim strLine As String
    Dim arrLine() As String, LineIndex As Long
    
    Close #1: Open strPath For Input As #1
    While Not EOF(1) And DataEnd = False
        Line Input #1, strLine
        If strLine = "SKCORD 1" Then DataStart = True
        If strLine = "ASPFN SAME" Then DataEnd = True
        If DataStart = True And DataEnd = False Then
            LineIndex = LineIndex + 1
            ReDim Preserve arrLine(1 To LineIndex)
            arrLine(LineIndex) = strLine
        End If
    Wend
    Close #1
    
    If LineIndex > 1 Then
        ReDim Preserve arrLine(1 To LineIndex - 1)
        ActiveSheet.[A1].Resize(LineIndex - 1, 1).Value = WorksheetFunction.Transpose(arrLine)
    End If
    Application.ScreenUpdating = True
    
End Sub

Hope that helps,
~tigeravatar

Hi tigeravatar,

The logic that you gave me worked perfectly. Thanks for that !!!!