VBA数据排序

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

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

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

示例/想法： 我认为脚本将必须获取一个单元格（例如D9，并识别它是一个D和偏移量）来选择D10，并将该D9记录与第2页的D列相匹配，并将D10数据粘贴到D10而不是D5中

第二个示例，脚本获取I17并识别它将I匹配到第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

Sub-main（）
模糊Hedaeras范围
作为变体的暗淡标签阵列
使用ThisWorkbook.Worksheets（“Sheet2”）”我建议您不要逐列复制，而是逐行复制

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

公共子副本数据（）
暗输入与长输入相同
暗输出与长输出相同
将输入表作为工作表进行调整
将输出表设置为工作表
设置输入表=工作表（“表1”）
设置outputSheet=工作表（“Sheet2”）
'首先，复制标题
inputSheet.Rows（1）。复制outputSheet.Rows（1）
'接下来，复制第一行数据
inputSheet.Rows（2）。复制outputSheet.Rows（2）
'循环浏览工作表的其余部分，为每个附加标题行复制数据行
inputRow=3
输出流量=3
而inputSheet.Cells（inputRow，1）”
inputRow=数据行的inputRow+1'增量
inputSheet.Rows（inputRow）。复制outputSheet.Rows（outputRow）
inputRow=inputRow+1'到下一个潜在标题行的增量
outputRow=到下一个空白输出行的outputRow+1'增量
温德
端接头
为了子孙后代，我将保留我以前的答案，但现在你已经澄清了你的问题，我有一个更好的答案给你

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

例如：

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到K表示类别标题。任何特殊字符数的值表示在每个类别下收集的数据。您可能会注意到，某些类别没有特定数据集的值（行号）因此，我找不到一种方法来将空白单元格复制到第二张纸上。相反，在当前代码中，它简单地忽略了任何空白。这就是为什么我希望在粘贴数据集的原始行号的第二页中的数据时偏移。因此，您尝试将顶部数据转换为底部数据-基本上只是STR。ip输出额外的标题？两个问题：是否保证第一行中的所有标题都将被填写，以及是否保证每隔一行都是标题行？此外，您是否正在对同一工作表进行更改，还是正在尝试复制到新工作表？它是将数据复制到具有范围内预定义标题的新工作表A1:K1.我想我可能需要完全重新构建，因为现在知道使用最后一行有很多问题，我认为可能有效的方法是，如果您知道一种方法，在宏运行时从原始数据中提取行值，然后我们将其指定为变量，并使用它将sheet2中的数据粘贴到d期间找到的正确列中ata匹配。例如，宏检测A2:K3范围内的数据集，并将第2行识别为标题，将第3行识别为值。它继续分配一个值为3的变量，指定值的行号。它继续将数据匹配为更正标题a到a、B到B等，但在粘贴值时，它将引用行输入的变量（在本例中为其第3行），而不是使用最后一行（与当前一样）。然后我需要做的就是删除所有完全空白的行，只需简单的格式化。我将在大约一个小时内试用此代码，并会让您知道它是否有效！感谢您花时间帮助我解决此问题，我知道我们都过着忙碌的生活。出现的唯一问题是：我将有标题为A B的行C D E F G H I J K和其他具有B C D E G H I J K的文件。因此，在没有单独数据匹配的情况下，它们将无法与各自的文件头对齐。第一个文件头行是否保证有所有的文件头？您的意思是像示例中的H9和H10一样为空？我的代码仍然有效。我是否应该定义字典以避免用户定义的类型未定义？Dim headers Set headers=CreateObject（“Scripting.Dictionary”）您可以使用“早期绑定”让VBA直接识别此代码，方法是单击（在VBA IDE中）“工具”-->“引用…”并选中“Microsoft脚本运行时”旁边的框。我更喜欢使用“后期绑定”（使用CreateObject）因为你可以通过F2访问IntelliSense和对象模型。非常正确，你真的是一个excel
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

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