Macro to sort dynamic list into table

Hello everyone please could someone take a look at a macro for me?
I have a list of letting agents that I need to sort into a table to import into Access. The list is dynamic in that not all the fields are present for every record.
I will have over 4000 records to sort out, so I would really like to automate this.
If possible the macro should read rows from the data worksheet and write to columns and rows on the Table worksheet.
I have attached a small example of the data and output required.
To make it a little more challenging the column header name is part of the data and will need stripping out as well.

Thanks for looking.

Regards
Andrew

Lettings Agents.xls

Andrew

See how this goes.

Sub extracter()
  Dim OutSH As Worksheet
  Set OutSH = Sheets("Table")
  OutSH.Cells.ClearContents
  OutSH.Range("A1:F1").Value = Array("Name", "Location", "Telephone", "Email", "Web Site", "Description")
  
  For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row - 3
    If Not IsEmpty(Cells(i, 1)) And InStr(1, Cells(i, 1).Value, ":") = 0 Then
      outrow = OutSH.Cells(Rows.Count, 1).End(xlUp).Row + 1
      OutSH.Cells(outrow, 1).Value = Cells(i, 1).Value
    ElseIf Not IsEmpty(Cells(i, 1)) And InStr(1, Cells(i, 1).Value, ":") > 0 Then
      placer = InStr(1, Cells(i, 1).Value, ":")
      outcol = WorksheetFunction.Match(Left(Cells(i, 1).Value, placer - 1), OutSH.Rows("1:1"), 0)
      
      Select Case Left(Cells(i, 1).Value, placer - 1)
        Case "Description"
          OutSH.Cells(outrow, outcol).Value = Cells(i + 1, 1).Value ', Len(Cells(i + 1, 1).Value) - placer))
          i = i + 1
        Case Else
          OutSH.Cells(outrow, outcol).Value = Trim(Right(Cells(i, 1).Value, Len(Cells(i, 1).Value) - placer))
      End Select
    End If
  Next i
          
End Sub

rylo

Hello Andy748,

Here is another macro for you to copy the data into a table. Theis macro has already been added to the attached workbook.

Sub CopyDataToTable()

  Dim DstWks As Worksheet
  Dim LastRow As Long
  Dim N As Long
  Dim R As Long
  Dim Rng As Range
  Dim SrcWks As Worksheet
  Dim StartRow As Long
  
    Set DstWks = Worksheets("Table")
    Set SrcWks = Worksheets("Data")
    
    StartRow = 1
    LastRow = SrcWks.Cells(Rows.Count, "A").End(xlUp).Row
    LastRow = IIf(LastRow < StartRow, StartRow, LastRow)
    
      
      R = 2          'Destination worksheet starting row
      N = StartRow   'Source worksheet starting row
      
     'Clear the Destination worksheet of previous data
      DstWks.UsedRange.Offset(1, 0).ClearContents
      
     'Find the Source data, format it, and copy it to the Destination worksheet
      With SrcWks
        Do
          N = .Cells(N + 4, "A").Row
          Set Rng = .Cells(N, "A").CurrentRegion
          N = Rng.Rows(Rng.Rows.Count).End(xlDown).Row
          If N < LastRow Then
            DstWks.Cells(R, "A") = .Cells(Rng.Row - 4, "A")
            DstWks.Cells(R, "B") = Split(.Cells(Rng.Row - 2, "A"), ":")(1)
            DstWks.Cells(R, "C") = Split(.Cells(Rng.Row, "A"), ":")(1)
            DstWks.Cells(R, "D") = Split(.Cells(Rng.Row + 1, "A"), ":")(1)
            DstWks.Cells(R, "E") = Split(.Cells(Rng.Row + 2, "A"), ":")(1)
            DstWks.Cells(R, "F") = .Cells(Rng.Row + 4, "A")
            R = R + 1
         Else
            Exit Do
          End If
        Loop
      End With
    
End Sub

Sincerely,
Leith Ross

Thanks guys both macros worked, but I went with rylo's as the data was more dynamic (messy) than I first thought.
Two good macros though, I am still trying to work out exactly how they work, as that is the important bit for me.
Thanks once again Leith Ross and rylo.