Data Sorting Macro - Please help

Have you tried the "text to columns" tool? I don't know if it will do what you want, but maybe it's worth a shot.

Seems to me like a good first attempt would be to transpose all the data sets into columns and then to delete the unnecessary columns?

Hello paconovellino,

The attached workbook organizes the data by date, ID, agent name, task, and time. The data is then output to Sheet3 starting in row 2. Row 1 has headers. There are no blank rows in data. There is a button at the top of Sheet3 to run the macro.

The macro is very fast. The average execution time on my computer is 0.21 seconds. Here is the macro code. There are 2 standard VBA modules used in this project.

Fast_Find Module Macro

Function FastFind(ByVal FindItem As Variant, ByRef FindRng As Range) As Variant

  ' Written: July 17, 2013
  ' Author:  Leith Ross
  ' Summary: Searchs a single column using the MATCH function instead of Range Find method.
  '             This method is much faster and a better choice for data sets of 10,000 rows
  '             or more. Checking the zero subscript of the returned array of cells will
  '             will either be a range, if successful, or empty. The number of matches found
  '             is equal to the UBound of the array + 1. The returned array of cells is a
  '             contiguous 1-D array of the cells that matched the search criteria.
  
  
    Dim cnt         As Long
    Dim Data()      As Variant
    Dim n           As Long
    Dim r           As Variant
    Dim Rng         As Range
    Dim RngEnd      As Range
    Dim Wks         As Worksheet
    
        Set Wks = FindRng.Parent
        
        Set Rng = FindRng
        Set RngEnd = FindRng.Cells(FindRng.Rows.Count + FindRng.Row - 1, 1)
        
            ReDim Data(0 To FindRng.Rows.Count)
            
            For n = r To Rng.Rows.Count
                r = Application.Match(FindItem, FindRng, 0)
                If VarType(r) <> vbError Then
                    Set Data(cnt) = FindRng.Cells(r, 1)
                    cnt = cnt + 1
                    
                  ' Shorten the FindRng for the next search.
                    r = r + 1
                    Set FindRng = Wks.Range(FindRng.Cells(r, 1), RngEnd)
                Else
                    Exit For
                End If
            Next n
                
        If cnt Then ReDim Preserve Data(cnt)
        FastFind = Data
    
End Function

Module1 Macro

Sub Macro1()

    Dim AgentName   As String
    Dim Cell        As Variant
    Dim DataOut     As Variant
    Dim Dates       As Variant
    Dim DateCell    As Variant
    Dim DateRng     As Range
    Dim Details     As Variant
    Dim EntryDate   As Variant
    Dim i           As Long
    Dim ID          As Double
    Dim Item        As Variant
    Dim n           As Long
    Dim r           As Long
    Dim RegExp      As Object
    Dim Rng         As Range
    Dim RngEnd      As Range
    Dim Wks         As Worksheet
    
        Set Wks = Worksheets("Sheet2")
        
        Set Rng = Wks.Range("A1")
        Set RngEnd = Wks.Cells(Rows.Count, "A").End(xlUp)
        
        Set Rng = Wks.Range(Rng, RngEnd)
        
            Set RegExp = CreateObject("VBScript.RegExp")
            RegExp.Pattern = "^\s+(\d+)\s(.+)"
            
            Dates = FastFind("*ID Agent Name*", Rng)
               
            ReDim DataOut(1 To RngEnd.Row, 1 To 5)
   
            For i = 0 To UBound(Dates) - 1
                Set DateCell = Dates(i)
                EntryDate = Mid(DateCell, 50, 8)
                EntryDate = Format(EntryDate, "dd/mm/yyyy")
                
                If i + 1 < UBound(Dates) Then
                    Set DateRng = DateCell.Resize(Dates(i + 1).Row - DateCell.Row, 1)
                Else
                    Set DateRng = DateCell.Resize(RngEnd.Row - DateCell.Row, 1)
                End If
                
                  ' Find ID numbers and Agent Names for this date.
                    For Each Cell In DateRng
                        If RegExp.Test(Cell) Then
                            ID = Val(RegExp.Replace(Cell, "$1"))
                            AgentName = RTrim(RegExp.Replace(Cell, "$2"))

                            r = Cell.End(xlDown).Row
                            
                            If r - Cell.Row = 1 Then
                                ReDim Details(1 To 1, 1 To 1)
                                Details(1, 1) = Cell.Offset(1, 0).Value
                            Else
                                Details = Cell.Offset(1, 0).Resize(r - Cell.Row, 1).Value
                            End If
                            
                            For Each Item In Details
                                n = n + 1
                                DataOut(n, 1) = EntryDate
                                DataOut(n, 2) = ID
                                DataOut(n, 3) = AgentName
                                DataOut(n, 4) = RTrim(Mid(Item, 16, 41 - 16))
                                DataOut(n, 5) = RTrim(Mid(Item, 42, 50 - 42))
                            Next Item
                        End If
                    Next Cell
            Next i
        
      ' Output the data to Sheet3 starting in row 2.
        Sheet3.Range("A2:E2").Resize(n, 5).Value = DataOut
    
End Sub