使用 VBA & VLOOKUP 将列范围重组为行

Question

我有 2019 年的两列，一列有月份，另一列对应于该月。 我想用几个月作为标题和下面的金额重新组织它，如所附屏幕截图所示。

我对第一对使用了 VLOOKUP，但有超过 100,000 行，手动更新每个 VLOOKUP 的范围需要很长时间。

问题是并非所有数据都是统一的。 如果数据在 1 月开始并在 12 月结束，那就太好了，但事实并非如此。 看第二张截图

其中显示数据从 7 月开始到 12 月结束，有些数据从 1 月开始到 7 月结束。 在数据集的末尾，有数百个新账户在 12 月开设，因此唯一可用的数据仅为 12 月份的数据。 所以，它因人而异。

有没有办法利用 VBA 和 VLOOKUP 自动对具有一个 header 的列进行排序，即 1-12 个月，以及下面的所有金额？ 然后，这些数据将与用户帐户信息合并，这就是我希望将其全部放在 1 行中的原因。

如果您有其他建议，请告诉我。 任何帮助表示赞赏！

PS我发现这个链接对于转置由空白行分隔的范围很有用： VBA to transpose data based on empty lines

如何将 VLOOKUP 纳入其中？

Answer 1

看来您已经找到了使用 VLookup 获取数据的解决方案。 您没有找到如何将公式复制到 100K 单元格的解决方案。 这里是。

1. Select 单元格与原始公式
2. 复制（可以使用 Ctl+C）
3. 在 Home 选项卡上单击Find & Select然后转到...
4. 在参考字段中写入目标范围，例如B2:K500000
5. 单击确定（这将 select 目标范围）
6. 按Enter （这将完成粘贴操作）

Answer 2

这是一个选项。 它使用月份来确定放置值的列（从 D 开始）。 一旦在数据集之间找到一个或多个空白行，它就会移动到新行。

Option Explicit

Public Sub Process()

    Dim TargetRow As Long
    Dim SourceRange As Range
    Dim DateCell As Range
    Dim LastRowWasBlank As Boolean

    Set SourceRange = ActiveSheet.Range("A2:A" & ActiveSheet.Cells(1048576, 1).End(xlUp).Row)
    TargetRow = 2
    For Each DateCell In SourceRange
        If DateCell.Cells(1, 1) <> "" Then
            LastRowWasBlank = False
            ActiveSheet.Cells(TargetRow, 3 + Month(DateCell.Cells(1, 1))) = DateCell.Cells(1, 2)
        Else
            If LastRowWasBlank <> True Then
                LastRowWasBlank = True
                TargetRow = TargetRow + 1
            End If
        End If
    Next

End Sub

Answer 3

用空单元格转置

• 将完整的代码复制到标准模块（例如Module1 ）中。
• 仔细调整常量部分中的值。
• 仅运行Sub 。 Function由Sub调用。

编码

Sub transposeMonths()

    ' Define constants.
    Const srcNameOrIndex As Variant = "Sheet1"
    Const FirstRow As Long = 2
    Const SourceColumn As Long = 1
    Const ValueColumn As Long = 2
    Const tgtNameOrIndex As Variant = "Sheet1"
    Const tgtFirstCell As String = "D1"
    Const Separator As String = "-"
    Dim CurrYear As Long: CurrYear = 2019
    Dim Months As Variant
    Months = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", _
                   "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
    Dim wb As Workbook: Set wb = ThisWorkbook

    ' Add Separator and Current Year to Months Array.
    Dim ubM As Long: ubM = UBound(Months)
    Dim j As Long
    For j = 0 To ubM
        Months(j) = Months(j) & Separator & CurrYear
    Next j
    Months = Application.Transpose(Application.Transpose(Months))
    ubM = ubM + 1

    ' Read from Source Ranges to Source Arrays.
    Dim src As Worksheet: Set src = wb.Worksheets(srcNameOrIndex)
    Dim Source(1) As Variant
    Source(0) = getColumnValues(src, SourceColumn, FirstRow)
    Dim ubS As Long: ubS = UBound(Source(0))
    Source(1) = src.Cells(FirstRow, ValueColumn).Resize(ubS)
    Set src = Nothing

    ' Count unique items.
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    Dim CurrMonth As String, i As Long
    For i = 1 To ubS
        CurrMonth = Source(0)(i, 1)
        If CurrMonth <> "" Then
            dict(CurrMonth) = dict(CurrMonth) + 1
        End If
    Next i

    ' Write from Source Arrays to Target Array.
    Dim Target As Variant
    ReDim Target(1 To Application.Max(dict.Items) + 1, 1 To ubM)
    For j = 1 To ubM
        Target(1, j) = Months(j)
    Next j
    For i = ubS To 1 Step -1
        CurrMonth = Source(0)(i, 1)
        If CurrMonth <> "" Then
            Target(dict(CurrMonth) + 1, Application.Match(CurrMonth, Months, 0)) _
              = Source(1)(i, 1)
            dict(CurrMonth) = dict(CurrMonth) - 1
        End If
    Next i

    ' Write from Target Array to Target Range.
    Dim tgt As Worksheet: Set tgt = wb.Worksheets(tgtNameOrIndex)
    tgt.Range(tgtFirstCell).Resize(UBound(Target), UBound(Target, 2)) = Target

    ' Inform user.
    MsgBox "Data copied.", vbInformation, "Success"

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes the values of a non-empty one-column range starting     '
'               from a specified row, to a 2D one-based one-column array.      '
' Returns:      A 2D one-based one-column array.                               '
' Remarks:      If the column is empty or its last non-empty row is above      '
'               the specified row or if an error occurs the function will      '
'               return an empty variant. Therefore the function's result       '
'               can be tested with "IsEmpty".                                  '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getColumnValues(Sheet As Worksheet, _
                         Optional ByVal AnyColumn As Variant = 1, _
                         Optional ByVal FirstRow As Long = 1) _
        As Variant

    On Error GoTo exitProcedure
    Dim rng As Range
    Set rng = Sheet.Columns(AnyColumn).Find("*", , xlValues, , , xlPrevious)
    If rng Is Nothing Then Exit Function
    If rng.Row < FirstRow Then Exit Function
    Set rng = Sheet.Range(Sheet.Cells(FirstRow, AnyColumn), rng)

    Dim Result As Variant
    If rng.Rows.Count = 1 Then
        ReDim Result(1 To 1, 1 To 1): Result(1, 1) = rng.Value
    Else
        Result = rng.Value
    End If
    getColumnValues = Result

exitProcedure:
End Function