excelvbaexportreporting

Writing VBA to take data from multiple sheets, organize them side by side chronologically downward (timeline) comparing the dates on multi-tables

I have tabular data with unique values in column A. Based on column A, i want to create tables placed to the side-by-side, whenever new values in column A are identified. Then I need to sort the date column for both side by side tables as earliest to latest. Essentially i'm looking to create a view where each table is sorted downwards but when that column A has unique values, all those unique values show on a table to the right, but visually in relation to each other. Inserting blank rows as needed to showcase the timeline might help.

As a simple example:

  1. A sample table:
    enter image description here enter image description here
  2. Ideally the spaces don't have to be full blank rows, it can be 'relational', so enough white space to mimic the gap in time when comparing against each other.

Please let me know if I should be approaching this differently altogether.

I've tried first taking the table and creating new tabs for each unique value in column A. then combining the data side by side.

The sorting of the data in relation to each other is where I'm not able to find an appropriate method.

Here's what i've tried so far:

Sub SeparateData()
    Dim ws As Worksheet
    Dim last_row As Long
    Dim unique_values As Variant
    Dim i As Long
    Dim current_col As Long
    Dim cell As Range
    Dim check_range As Range
    Dim moved_rows As Range
    
    ' Set the worksheet
    Set ws = ThisWorkbook.Sheets("Sheet11") ' Change "Sheet1" to the name of your sheet
    
    ' Sort by date (Column D)
    With ws
        last_row = .Cells(.Rows.Count, "D").End(xlUp).Row
        .Range("A1:F" & last_row).Sort key1:=.Range("D1"), order1:=xlAscending, Header:=xlYes
    End With
    
    ' Get unique values from Column A
    unique_values = WorksheetFunction.Transpose(ws.Range("A2:A" & last_row).Value)
    unique_values = WorksheetFunction.Unique(unique_values)
    
    ' Start from column G
    current_col = 7
    
    ' Loop through each unique value in column A
    For i = LBound(unique_values) To UBound(unique_values)
        ' Find the next available column to paste the data
        current_col = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column + 2
        
        ' Initialize moved_rows range
        If moved_rows Is Nothing Then
            Set moved_rows = ws.Cells(1, 1)
        End If
        
        ' Loop through each cell in column A
        For Each cell In ws.Range("A2:A" & last_row)
            ' Check if the value in column A matches the current unique value
            If cell.Value = unique_values(i) Then
                ' Check if the row has already been moved
                If Not Intersect(cell, moved_rows) Is Nothing Then
                    ' Find the column where the data has already been moved
                    current_col = Intersect(cell, moved_rows).Column
                Else
                    ' Copy column headers along with the data
                    ws.Range(ws.Cells(1, 1), ws.Cells(1, 6)).Resize(2).Copy Destination:=ws.Cells(1, current_col)
                    ' Copy the data to the next available column
                    cell.Resize(, 6).Copy ws.Cells(cell.Row, current_col)
                    ' Add the moved row to the moved_rows range
                    If moved_rows Is Nothing Then
                        Set moved_rows = cell
                    Else
                        Set moved_rows = Union(moved_rows, cell)
                    End If
                End If
            End If
        Next cell
    Next i
    
    MsgBox "Data separated successfully!"
End Sub

I'm struggling here as some data is moving successfully, but im seeing errors in the tables being 'moved into'.

Solution 
  • Option Explicit
Sub Demo()
    Dim objDic As Object, rngData As Range
    Dim i As Long, j As Long, sKey As String, iCnt As Long
    Dim arrData, arrRes, RowCnt As Long, ColCnt As Long
    Const DATE_COL = 3
    Set objDic = CreateObject("scripting.dictionary")
    With Sheets("Sheet1")
    Set rngData = .Range("A1").CurrentRegion
    ' sort table
    rngData.Sort key1:=.Columns(DATE_COL), order1:=xlAscending, Header:=xlYes
    End With
    ' load data into array
    arrData = rngData.Value
    RowCnt = UBound(arrData)
    ColCnt = UBound(arrData, 2)
    ' get unique list
    For i = LBound(arrData) + 1 To UBound(arrData)
        sKey = arrData(i, 1)
        If Not objDic.exists(sKey) Then
            objDic(sKey) = iCnt
            iCnt = iCnt + 1
        End If
    Next i
    ReDim arrRes(1 To RowCnt, 1 To ColCnt * objDic.Count)
    ' populate header
    For i = 0 To objDic.Count - 1
        For j = 1 To ColCnt
            arrRes(1, j + ColCnt * i) = arrData(1, j)
        Next
    Next
    ' move data row
    For i = LBound(arrData) + 1 To UBound(arrData)
        iCnt = objDic(arrData(i, 1))
        For j = 1 To ColCnt
            arrRes(i, j + ColCnt * iCnt) = arrData(i, j)
        Next
    Next i
    ' write output to sheet
    Sheets.Add
    Range("A1").Resize(RowCnt, UBound(arrRes, 2)) = arrRes
    For i = 0 To objDic.Count - 1
        Columns(DATE_COL + ColCnt * i).NumberFormat = "yyyy-MM-dd"
    Next
    Set objDic = Nothing
End Sub

    enter image description here