编写VBA从多张表中获取数据，按时间顺序向下（时间轴）并排组织它们，比较多表上的日期

Question

我的表格数据在 A 列中具有唯一值。 基于 A 列，每当识别出 A 列中的新值时，我想创建并排放置的表。然后我需要将两个并排表的日期列按最早到最新的顺序排序。本质上，我希望创建一个视图，其中每个表都向下排序，但是当 A 列具有唯一值时，所有这些唯一值都显示在右侧的表中，但在视觉上彼此相关。根据需要插入空白行以展示时间线可能会有所帮助。

举个简单的例子：

1. 示例表：
   
2. 理想情况下，空格不必是完整的空白行，它可以是“相关的”，因此有足够的空白来模拟相互比较时的时间间隙。

请让我知道我是否应该完全以不同的方式处理这个问题。

我首先尝试获取表格并为 A 列中的每个唯一值创建新选项卡。 然后并排组合数据。

数据相互关联的排序是我无法找到合适的方法。

这是我迄今为止尝试过的：

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

我在这里苦苦挣扎，因为一些数据正在成功移动，但我看到表中的错误被“移入”。

Answer 1

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