数据的 VBA 排序

Question

我遇到的问题是，有时数据集中缺少整个标题和数据值，因此使用脚本中的最后一行数据会向上移动一个。例如，如果我在 sheet1 上完全删除 H11:H12，那么与 A11:K11 中的数据集关联的 H 列的值实际上将来自数据集 A13:K13（或单元格值 H14）。

如果相应的标题不存在，第二张图片中显示的空格将不存在。

问题：给出以下代码；您是否认为可以将数据与标题匹配，并在第 2 页上匹配的列旁边使用原始偏移行号并将值粘贴到那里？取而代之的是当前代码（唯一有效的方法是找到最后一行）。

示例/想法： 我认为脚本将必须采用一个单元格（例如 D9 并识别它是一个 D 和偏移量以选择 D10 并将该 D9 记录匹配到工作表 2 列 D 并将 D10 数据粘贴到 D10 而不是 D5 中。

第二个示例，脚本获取 I17 并识别它与工作表 2 列 I 匹配，然后偏移以选择/复制并将 I19 数据粘贴到 I18 而不是 I9 中。

Sub main()
    Dim hedaerCell As Range
    Dim labelsArray As Variant

    With ThisWorkbook.Worksheets("Sheet2") '<--| reference "headers" worksheet
        For Each hedaerCell In .Range("A1:K1") '<--| loop through all "headers"
            labelsArray = GetValues(hedaerCell.Value) '<--| fill array with all labels found under current "header"
            .Cells(.Rows.Count, hedaerCell.Column).End(xlUp).Offset(1).Resize(UBound(labelsArray)).Value = Application.Transpose(labelsArray)
            Next
    End With
End Sub

Function GetValues(header As String) As Variant
    Dim f As Range
    Dim firstAddress As String
    Dim iFound As Long

    With ThisWorkbook.Worksheets("Sheet1").UsedRange '<--| reference "data" worksheet
        ReDim labelsArray(1 To WorksheetFunction.CountIf(.Cells, header)) As Variant '<--| size an array to store as many "labels" as passed 'header' occurrences
        Set f = .Find(what:=header, LookIn:=xlValues, lookat:=xlWhole) '<--| start seraching for passed 'header'
        If Not f Is Nothing Then
            firstAddress = f.Address
            Do
                iFound = iFound + 1
                labelsArray(iFound) = f.Offset(1)
                Set f = .FindNext(f)
            Loop While f.Address <> firstAddress
        End If
    End With
    GetValues = labelsArray
End Function

---

补充：

似乎有一个异常阻止这些单元格值被复制，如果我手动执行，下面的屏幕截图将是正确的。有什么诊断技巧吗？

非常奇怪，因为带有红点的行在两者中都可以正常复制，但是这四行似乎失败了。

Answer 1

为了后代，我将保留我以前的答案，但现在你已经澄清了你的问题，我有一个更好的答案给你。

我将假设以下内容： 1. 每两行是一对标题/数据； 2. 行对集合的长度可能不相等，因为如果特定行对缺少特定标题，则没有空白，因为标题/数据向左移动； 3. 标题行直到行尾都没有空格 4. 数据行可能有空格 5. 输出应该是每个标题（即使它只出现在 1 行中）和相关的行数据，原始工作表中的每个标题/数据对一个。

例如：

A|B|C|D|F|G|H|I  <--- some headers (missing E)
1|2|3|4|6|7|8|9  <--- data row 1
A|C|D|E|G|H|I    <--- some headers (missing B and F)
1|3|4|5|7|8|9    <--- data row 2

是一个有效的输入表，结果输出表将是：

A|B|C|D|E|F|G|H|I  <--- all headers
1|2|3|4| |6|7|8|9  <--- data row 1
1| |3|4|5| |7|8|9  <--- data row 2

使用 Scripting.Dictionary 的 Scripting.Dictionary 来跟踪可能不同长度的标题/数据行对。标头的 Scripting.Dictionary 允许您在新标头出现时添加它们。嵌套的 Scripting.Dictionarys 允许您仅跟踪具有特定标头值的行，但也保留行号以供以后使用。

如 cmets 中所述，代码遍历此结构以显示所有标题和与每一行关联的数据。 "((inputRow - 1) / 2)" 计算输出行数。您会注意到我喜欢在计数上迭代 for 循环，然后使用偏移量进行索引。我发现以这种方式推理我的代码更容易，而且我发现操作更容易，但你可以根据需要更改它。

Public Sub CopyDataDynamically()
    Dim inputSheet As Worksheet
    Dim outputSheet As Worksheet

    Dim headers As Scripting.Dictionary
    Set headers = New Scripting.Dictionary

    Dim header As String
    Dim data As String

    Dim inputRow As Long
    Dim inputColumn As Long

    Set inputSheet = Worksheets("Sheet1")
    Set outputSheet = Worksheets("Sheet2")

    inputRow = 1

    While Not inputSheet.Cells(inputRow, 1) = ""
        inputCol = 1
        While Not inputSheet.Cells(inputRow, inputCol) = ""

            header = inputSheet.Cells(inputRow, inputCol).Value
            data = inputSheet.Cells(inputRow + 1, inputCol).Value

            If Not headers.Exists(header) Then
                headers.Add header, New Scripting.Dictionary
            End If
            headers(header).Add ((inputRow - 1) / 2) + 1, data
            inputCol = inputCol + 1
        Wend
        inputRow = inputRow + 2
    Wend

    'Output the structure to the new sheet
    For c = 0 To headers.Count - 1
        outputSheet.Cells(1, c + 1).Value = headers.Keys(c)
        For r = 0 To ((inputRow - 1) / 2) - 1
            If headers(headers.Keys(c)).Exists(r + 1) Then
                outputSheet.Cells(r + 2, c + 1).Value = headers(headers.Keys(c))(r + 1)
            End If
        Next
    Next
End Sub

Answer 2

我建议，不要逐列复制，而是逐行复制。

Public Sub CopyData()
    Dim inputRow As Long
    Dim outputRow As Long
    Dim inputSheet As Worksheet
    Dim outputSheet As Worksheet

    Set inputSheet = Worksheets("Sheet1")
    Set outputSheet = Worksheets("Sheet2")

    'First, copy the headers
    inputSheet.Rows(1).Copy outputSheet.Rows(1)

    'Next, copy the first row of data
    inputSheet.Rows(2).Copy outputSheet.Rows(2)

    'Loop through the rest of the sheet, copying the data row for each additional header row
    inputRow = 3
    outputRow = 3
    While inputSheet.Cells(inputRow, 1) <> ""
        inputRow = inputRow + 1 'increment to the data row
        inputSheet.Rows(inputRow).Copy outputSheet.Rows(outputRow)
        inputRow = inputRow + 1 'increment to the next potential header row
        outputRow = outputRow + 1 'increment to the next blank output row
    Wend
End Sub