Need help with macro

[hiddukel]

Hello all,

I have very little experience with macros/VBA, and I need some help with extracting specific text from a large .txt file into excel. (I know similar things have been asked before but I have not been able to find code that I could use for my purpose.)

The "txt" file I have contains library search results from research databases, and contains data looking like this:

TY - JOUR
AB - Experimental intervention was used etc. The results were etc. Several sentences and so on.
AD - Department of example, University of Example.
AN - 11111111
AU - Williams, I
AU - Smith, J
DA - Feb
DB - MEDLINE
(and some other lines, then a blank line and information repeated to about 22000 results).

The stuff I've bolded are what I was hoping to extract, such that column A contains the information after AB, column B contains info after AN, etc. Then next row containing same things for the next search item.

Would anyone be able to help? Thanks in advance.

AM

 

[rpaulson]

try this on a copy of your file

you will need to create a new worksheet and name it Results

Sub do_it()

Dim rs As Worksheet
Set rs = Worksheets("Results")

rs.Cells.ClearContents

On Error Resume Next

For r = 1 To Cells(Rows.Count, "A").End(xlUp).Row

x = Split(Cells(r, "A"), " - ")(0)
Data = Split(Cells(r, "A"), " - ")(1)
Select Case x

Case Is = "AB"
lr = rs.Cells(Rows.Count, "A").End(xlUp).Row + 1
rs.Cells(lr, "A") = Data

Case Is = "AN"
lr = rs.Cells(Rows.Count, "B").End(xlUp).Row + 1
rs.Cells(lr, "B") = Data

Case Is = "DB"
lr = rs.Cells(Rows.Count, "C").End(xlUp).Row + 1
rs.Cells(lr, "C") = Data

Case Else
End Select

Data = ""
Next r

On Error GoTo 0
End Sub

hth,

Ross

 

[DanteAmor]

Try this, Change sheetx by name of your sheet to put the data.

Sub extracting_specific_text()
    Dim wFile As String
    Dim l1 As Workbook, l2 As Workbook
    Dim s1 As Worksheet, s2 As Worksheet
    Dim lr As Long, j As Long, c As Range
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set s1 = Sheets("[COLOR=#ff0000]SheetX[/COLOR]")
    With Application.FileDialog(msoFileDialogFilePicker)
        If .Show = -1 Then wFile = .SelectedItems(1) Else Exit Sub
    End With
    
    Workbooks.OpenText Filename:=wFile, Origin:=xlMSDOS, StartRow:=1, _
        DataType:=xlDelimited, TextQualifier:=xlNone, ConsecutiveDelimiter:=False, _
        Tab:=False, Semicolon:=False, Comma:=False, Space:=False, _
        Other:=True, OtherChar:="-", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Set l2 = ActiveWorkbook
    Set s2 = l2.ActiveSheet
    '
    j = 1
    For Each c In s2.Range("A1", s2.Range("A" & Rows.Count).End(xlUp))
        Select Case Left(c.Value, 2)
            Case "AB", "AN", "DB"
                c.EntireRow.Copy s1.Rows(j)
                j = j + 1
        End Select
    Next
    l2.Close False
    Application.ScreenUpdating = False
    MsgBox "Done"
End Sub

 

[hiddukel]

Thanks very much Dante. This worked.

 

[hiddukel]

Thanks for your help.

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.