How to get rows of dates grouped

[kbarton]

Hi

The attached code will take multiple bank account statements from any number of worksheet, and put them in date order on a new sheet.

Transactions that contain the same date go on their own row despite being the same date. What I'm trying to achieve is to get the same date transactions for any number of accounts to populate the respective column identified by the the worksheet name. This way, movement of money between accounts is easily identified as it goes form Account 1, to Account 2, 3 etc....

Here is a the code, thanks to MickG and AlphaFrog.

 ub MG03Jul47()
Dim Dn      As Range
Dim Ws      As Worksheet
Dim sht     As Worksheet
Dim nRng    As Range
Dim nnRng   As Range
Dim Col     As Integer
Dim Rng     As Range
Dim c       As Integer
Dim Lst As Long
Dim PstRng As Range
On Error Resume Next
If Sheets("Total_Sheets").Select = False Then
    Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Total_Sheets"
End If
On Error GoTo 0
Col = 0
With Sheets("Total_Sheets")
.Cells.ClearContents
.Cells.Interior.ColorIndex = xlNone
.Cells.Borders.LineStyle = xlContinuous
End With
For Each Ws In Worksheets
   
   If Not Ws.Name = "Total_Sheets" And Not Ws.Name = "T_Sheets" Then
      
        With Ws
            Set Rng = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
        End With
        For Each Dn In Rng
            c = c + 1
            If IsNumeric(Dn) Then Exit For
        Next Dn
        With Sheets("Total_Sheets")
            Lst = .Range("A" & .Rows.Count).End(xlUp).Offset(1).Row
             Set nRng = Rng.Offset(c - 1).Resize(Rng.Count - c + 1, 7)
               nRng.Copy .Range("A" & Lst).Resize(nRng.Rows.Count, 7)
                Set nnRng = Rng.Offset(c - 1, 7).Resize(Rng.Count - c + 1, 2)
                 Set PstRng = .Range("H" & Lst).Offset(, Col).Resize(nnRng.Rows.Count, 2)
                 .Cells(1, PstRng.Column) = "Debits " & Split(Ws.Name, " ")(1)
                  .Cells(1, PstRng.Column + 1) = "Credits " & Split(Ws.Name, " ")(1)
                   nnRng.Copy PstRng
          
    Rows("1:1").Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .MergeCells = False
    End With
                   
                   
        End With
    End If
        Col = Col + 2
        c = 0
Next Ws
With Sheets("Total_Sheets")
    .Range("A1").Resize(, 7) = Array("Index", "Account Name", "Account Number", "Sort Code", "Date", "Type", "Description")
     Set Rng = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp)).Resize(, Col + 5)
     MsgBox Rng.Address 'Delete as required
     With Rng.Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 56
    End With
        Rng.Sort .Range("E2"), xlAscending
        Set Rng = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
        .Rows(1).Columns.AutoFit
         Rng.Resize(, 30).Columns.AutoFit
End With
Call cula(Rng.Resize(, 1).Offset(, 4))  'Call cula(Rng.Resize(, 5))
MsgBox "Run!!"
End Sub
Sub cula(R As Range)
Dim Col As Variant
Dim Dn As Range
Dim c As Date
Dim K As Variant
Col = Array(34, 35)
    With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
       
        For Each Dn In R
            If Not .Exists(Dn.Value) Then
                .Add Dn.Value, Dn
            Else
                Set .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
            End If
        Next
    c = 0
        For Each K In .keys
            If .Item(K).Count > 1 Then
                c = IIf(c = 2, 0, c)
               .Item(K).EntireRow.Interior.ColorIndex = Col(c)
                c = c + 1
            End If
        Next K
End With
End Sub

Any help very much appreciated. I can supply some dummy data if it helps.

Kev