Question

Here is a website with a list of books in a relatively simple format.

http://www.autism-resources.com/autism.bib
I copied the list into excel, and each group of % symbols is a listing for a book, with different details like keywords and such. for instance %T = titles.
I want to create a macro to search through the list and copy every row that starts with “% whatever marker i choose” to the B column

Here is code I found and changed to do pretty close to what I want, except I keep getting an error.

Sub SearchForString()

Dim LSearchRow As Integer
Dim LCopyToRow As Integer
Dim celltxt As String

On Error GoTo Err_Execute

LSearchRow = 1

LCopyToRow = 1

While Len(Range("A" & CStr(LSearchRow)).Value) > 0

    celltxt = ActiveSheet.Range("A" & CStr(LSearchRow)).Value

    If InStr(1, celltxt, "%T") > 0 Then

        Cells("A" & CStr(LSearchRow)).Select
        Selection.Copy

        Cells("B" & CStr(LCopyToRow)).Select
        ActiveCell.Paste

        LCopyToRow = LCopyToRow + 1

    End If

    LSearchRow = LSearchRow + 1

Wend

Application.CutCopyMode = False
Range("A1").Select

MsgBox "All matching data has been copied."

Exit Sub

Err_Execute:
    MsgBox "An error occurred."

End Sub

Also, I believe the:

While Len(range....) > 0    

is set to keep looping until the active cell is empty, but the data is separated by a blank row for each book. I can go through and delete the empty rows, but is there a way to get around that with code?

Answer 1

See if this works for you. I used a Web Query and downloaded the data to A1 on sheet “Raw”

'simple struct to describe each line of data
Public Type InfoLine
    Tag As String
    Data As String
End Type

Sub Tester()

    Dim rw As Range, src As Range
    Dim dest As Range
    Dim line As String
    Dim numBlank As Integer
    Dim HadContent As Boolean
    Dim info As InfoLine

    Set src = ThisWorkbook.Worksheets("Raw").Range("A1")
    Set rw = ThisWorkbook.Worksheets("Books").Rows(1)

    Application.ScreenUpdating = False

    numBlank = 0
    'stop after 10 consecutive blank cells
    Do While numBlank < 10
        line = Trim(src.Value)

        If Len(line) > 0 Then

            numBlank = 0
            info = GetInfoLine(line)

            If info.Tag <> "" Then

                Set dest = Nothing
                Select Case info.Tag
                    Case "T": Set dest = rw.Cells(1)
                    Case "B": Set dest = rw.Cells(2)
                    Case "A": Set dest = rw.Cells(3)
                End Select

                If Not dest Is Nothing Then
                    HadContent = True
                    'does the cell already have content?
                    If Len(dest.Value) > 0 Then
                        'add new line after line break
                        dest.Value = dest.Value & Chr(10) & info.Data
                    Else
                        dest.Value = info.Data
                    End If
                End If

            Else
                'no tag - continues previous line (if captured)
                If Not dest Is Nothing Then
                    dest.Value = dest.Value & " " & line
                End If
            End If
        Else
            numBlank = numBlank + 1
            If numBlank = 1 And HadContent Then Set rw = rw.Offset(1, 0)
            HadContent = False
        End If

        Set src = src.Offset(1, 0)
    Loop

    Application.ScreenUpdating = True

End Sub

Function GetInfoLine(line As String) As InfoLine
    Dim rv As InfoLine
    If line Like "%*" Then
        rv.Tag = UCase(Trim(Mid(line, 2, InStr(1, line, " ", 0) - 2)))
        rv.Data = Trim(Mid(line, InStr(line, " ")))
    Else
        rv.Tag = ""
        rv.Data = line
    End If
    GetInfoLine = rv
End Function