finding second occurrence is not working - HELP!

[allanppark]

Hey guys,

I've been working on this macro, which brings data from the website crunchbase
At some point it finds the word "Investors" and copies the information below this cell and put all together in just another cell.
I need to do it for the second occurrence of "Investors:" as well, but still bringing the information below the first occurrence of "investors:"

Can you help me?

the code with the problem is in blue.

Could you help me please?

Sub Macro1()

Dim site As String
Dim tag As String
Dim i As Integer
Dim s As Integer
Dim nrows As Integer
Dim LAstrow As Long
        Dim r As Excel.Range
      Dim d As Excel.Range




nrows = Sheets("Sheet1").Range("B1").Value

For s = nrows To Sheets("Sheet1").Cells(nrows, 5).End(xlDown).Row
site = Sheets("Sheet1").Cells(s, 5).Value

Sheets("Sheet2").Activate

    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.crunchbase.com/organization/" & site, Destination:=Range( _
        "$A$1"))
        .Name = "mattermark"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        On Error Resume Next
        .Refresh BackgroundQuery:=False
    End With

    For i = 7 To 27
    tag = Sheets("Sheet1").Cells(4, i).Value

    Sheets("Sheet2").Activate
    Range("A1").Select



If tag = "Investors:" Then



Set r = Sheets("Sheet2").Range("A:A").Find(What:="Investors:", LookAt:=xlWhole, MatchCase:=False)
Cells.FindNext(After:=ActiveCell).Activate

If Not r Is Nothing Then
    Sheets("Sheet1").Cells(s, i).Value = Join(Application.Transpose(Range(r.Offset(1).Address, r.End(xlDown).Address).Value), ", ")



End If




ElseIf tag = "investors2:" Then


Set d = Sheets("Sheet2").Range("A:A").FindNext(What:="Investors:", LookAt:=xlWhole, MatchCase:=False)

Cells.FindNext(After:=ActiveCell).Activate


If Not d Is Nothing Then
    Sheets("Sheet1").Cells(s, i).Value = Join(Application.Transpose(Range(d.Offset(1).Address, d.End(xlDown).Address).Value), ", ")





    End If






ElseIf tag <> "Funding Rounds" Then

Cells.Find(What:=tag, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate

    On Error Resume Next

    Selection.Offset(1, 0).Copy
    Sheets("Sheet1").Activate
    Cells(s, i).Select
    ActiveSheet.Paste













Else


Cells.Find(What:="Funding Rounds", After:=ActiveCell, LookIn:=xlFormulas _
        , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate

          On Error Resume Next

    Selection.Offset(3, 0).Copy
    Sheets("Sheet1").Activate
    Cells(s, i).Select
    ActiveSheet.Paste





End If



    Next i



    Sheets("Sheet2").Activate
    Cells.Select
    Selection.Clear

    ActiveWorkbook.Save

    Next s


End Sub

 

[Marc L]

Hi,

attach a workbook with a source worksheet with at least 2 investors
and a desired result worksheet …
​