ok, what you're trying to do is end up with
one row for each date, then the data in adjacent columns.
Are you wanting the data in any order?
OK.. here's what I did:
Assumptions:
Data is in sheet named "Data", date in column A, data in B-??
The summary will be in sheet named "Summary"
I defined a Dictionary item to store the data.
It saves LOTS of time instead of looping through an array!
I counted the non-blank cells in Column A of the data sheet
and looped through those cells.
I the dictionary item exists, I appended it with a "," as a separator.
Otherwise, I created the dictionary item.
Once stored, I reported the contents of the dictionary, splitting the data using
the "," separator.
if there is a possibility that the data contains a ",", then you should select
another unique delimiter.
let me know if it helps,
Sub test2()
Dim DDict, Stat, Data_Rowcnt, NewDat, datacnt, I, X, DArray, DataArray
Set DDict = CreateObject("Scripting.Dictionary")
Stat = DDict.RemoveAll 'Clear existing data in Dictionary
'--- Count records
--------------------------------------------------------------------------------\
-
Sheets("Data").Select
Data_Rowcnt =
Application.WorksheetFunction.CountA(Sheets("Data").Range("A1:A65500"))
datacnt = 0
Set DataRange = Sheets("Data").Range(Cells(2, 1), Cells(Data_Rowcnt, 1))
For Each Data In DataRange.Columns(1).Cells
If (Data.Row Mod 100 = 0) Then Application.StatusBar = Data.Row & " of "
& Data_Rowcnt
If (Not DDict.exists(Data.Value)) Then
NewDat = Cells(Data.Row, 2)
For I = 3 To 5
If (Cells(Data.Row, I) & "X" <> "X") Then
NewDat = NewDat & "," & Cells(Data.Row, I)
Else
Exit For
End If
Next I
DDict.Add Data.Value, NewDat
Else
For I = 2 To 5
If (Cells(Data.Row, I) & "X" <> "X") Then
DDict.Item(Data.Value) = DDict.Item(Data.Value) & "," &
Cells(Data.Row, I)
Else
Exit For
End If
Next I
End If
Next Data
Sheets("Summary").Select
Range("A2:Z65000").ClearContents
Range("A1") = "Date"
Range("B1") = "Data"
DArray = DDict.keys
For I = 0 To DDict.Count - 1
Cells(I + 2, 1) = DArray(I)
DataArray = Split(DDict.Item(DArray(I)), ",")
For X = 0 To UBound(DataArray)
Cells(I + 2, X + 2) = DataArray(X)
Next X
Next I
Application.StatusBar = False
End Sub