VBA数据sorting

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

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

问题：给出以下代码; 您认为可以将数据与标题匹配，并使用原始偏移行号与列表2上的列匹配，并将值粘贴到那里？ 相反，当前的代码（只有方法是find最后一行）。

示例/想法：我想脚本将不得不采取一个单元格（如D9，并认识到它是一个D和偏移量来selectD10和匹配D9logging到表2列D和粘贴在D10的D10数据比D5。

第二个例子，脚本采取I17，并认识到它匹配I到表2列I，然后偏移select/复制和粘贴I18数据在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.行对的集合的长度可能不相等，因为如果特定行对缺less特定的标题，则不存在空白，因为标题/数据向左移动; 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 

是一个有效的input工作表，最终的输出工作表是：

 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.Dictionarys的Scripting.Dictionary来跟踪头/数据可能不同长度的行对。 头文件的Scripting.Dictionary允许你添加新的头文件。 嵌套的Scripting.Dictionarys允许您只跟踪那些具有特定标题值的行，还可以保留行号以备后用。

如注释中所述，代码遍历此结构来显示所有标题和与每一行相关的数据。 “（（inputRow – 1）/ 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 

Answer 2

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

 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