Apologies for missing your posting in the other thread.
Try the following.
[vba]Option Explicit
Option Compare Text
Sub Consolidate()
Dim tgt As Range, Source As Range, CkRange As Range, Cel As Range
Dim Rw As Long, i As Long, Dt As Range
Dim c As Range
Dim WB As Workbook, w As Workbook
Dim ws As Worksheet


Application.ScreenUpdating = False
Set WB = ActiveWorkbook
i = 1
'Loop through each sheet after first
For Each w In Workbooks
If w.Name <> WB.Name And w.Name <> "Personal.xls" Then
Set ws = w.Worksheets(1)
'Find place to post result
Set tgt = WB.Sheets("Summary").Cells(Rows.Count, 1).End(xlUp).Offset(1)
'w.Activate
'Sheets(1).Activate
'Find data to copy and copy to target
Set Source = Range(ws.Cells(1, 1), ws.Cells(Rows.Count, 1).End(xlUp)).Resize(, 2)
Source.Interior.ColorIndex = 6
Rw = Source.Rows.Count
Source.Copy tgt
'Insert - at any blank cells
Set CkRange = tgt.Offset(, 1).Resize(Rw)
For Each Cel In CkRange
If Len(Cel) = 0 Then Cel = "-"
Next
'Move data to corresponding column
i = i + 1
CkRange.Cut tgt.Offset(, i - 1)
End If
Next
Sheets("Summary").Activate

'Part 2
'Find end of copied data
With WB.Sheets("Summary")
Rw = .Cells(Rows.Count, 1).End(xlUp).Row
Do
'Read last cell
Set Dt = .Cells(Rw, 1)
'Find location if date occurred before
Set c = Range(.Cells(1, 1), .Cells(Rw - 1, 1)).Find(Dt.Value, After:=.Cells(1, 1), LookIn:=xlFormulas)
'If found, move corresponding value to first found value
If Not c Is Nothing Then
Dt.End(xlToRight).Cut Cells(c.Row, Dt.End(xlToRight).Column)
Dt.EntireRow.Delete
End If
'Check next cell
Rw = Rw - 1
Loop Until Rw = 1
End With
Application.ScreenUpdating = True
End Sub
[/vba]