VBA数据排序 [英] VBA Sorting of Data

问题描述

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

The problem i run into is that sometimes entire headers and data values are missing in the dataset and therefore using the last row in the script the data is shifted up by one. For example, if i removed H11:H12 completely on sheet1 then the values for the H column associated with the data set in A11:K11 will actually be from the data set A13:K13 (or cell value H14).

如果相应的标题不存在，则第二个图像将不存在。

问题：您认为可以将数据与标题进行匹配，并使用第2页匹配的列旁边的原始偏移行号并将值粘贴在那里？相反，当前的代码（而且只有方法是找到最后一行）。

Question: Given the following code; Do you think it is possible to match the data to headers and use the original offset row number alongside the column that it is matched to on sheet 2 and paste the values there? Instead the current code (and only method that worked was to find the last row).

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

Examples/Thoughts: I'm thinking that the script will have to take a cell (such as D9 and recognizes it is a D and offsets to select D10 and matches that D9 record to sheet 2 column D and pastes the D10 data in D10 rather than D5.

第二个例子，脚本需要I17并识别它匹配I到第2列第I列，然后偏移量来选择/复制并粘贴I18中的I19数据，而不是I9。

second example, Script takes I17 and recognizes it matches I to sheet 2 column I and then offsets to select/copy and pastes the I19 data in I18 rather than 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

---

追加：

---

Addition:

似乎就像有一个例外，可以防止这些单元格值被复制，如果我手动执行下面的截图是正确的。任何诊断提示？

Seems like there is an exception that prevents these cell values from being copied over, if i do it manually the below screenshot would be correct. Any tips to diagnose?

非常奇怪，因为在这两条线上，红点复制好，但这四条线似乎都失败了。

Very strange because the line with the red dot copies fine in both but those four lines seem to fail.

推荐答案

我要离开我以前的答案，为了后代，现在你已经澄清了你的问题，我有一个更好的回答你

I'm leaving my previous answer up for posterity's sake, but now that you've clarified your question I have a better answer for you.

我要承担以下几点：1.每两行是一对标题/数据;行集合可能长度不等，因为如果特定行对丢失了特定的标题，则不存在空白，因为标题/数据向左移动;在标题行中不会有空格，直到行4的末尾。数据行5中可能有空白。输出应该是每个标题（即使它只出现在1行中）和相关联的行数据，原始表格中的每个标题/数据对中的一个。

I'm going to assume the following: 1. every two rows is a pair of headers/data; 2. the sets of row pairs may be unequal in length because if a particular header is missing for a particular row pair, there is no blank because the headers/data are shifted left; 3. there will be no blanks in the header rows until the end of the row 4. there may be blanks in the data row 5. the output should be every header (even if it only appears in 1 row) and rows of the associated data, one per header/data pair in the original sheet.

例如：

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

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

is a valid input sheet and the resulting output sheet would be:

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脚本.Dictionarys来跟踪标题/数据的可能不同长度的行对。标题的Scripting.Dictionary允许您在出现时添加新标题。嵌套的Scripting.Dictionarys允许您仅跟踪具有特定标题值的行，而且还可以保留行号以供以后使用。

Use a Scripting.Dictionary of Scripting.Dictionarys to keep track of the possibly different length row pairs of headers/data. The Scripting.Dictionary of headers allows you to add new headers as they appear. The nested Scripting.Dictionarys allow you to keep track of only those rows which have a value for a particular header, but also preserve the row number for later.

如上所述注释，代码遍历此结构以显示所有标题和与每行关联的数据。 （（inputRow - 1）/ 2）计算输出行号。你会注意到我喜欢迭代循环遍历计数，然后使用偏移进行索引。我觉得以这种方式更容易理解我的代码，我发现操作更容易，但是如果需要，你可以改变它。

As noted in the comments, the code iterates through this structure to display ALL headers and the data associated with each row. "((inputRow - 1) / 2)" calculates the output row number. You'll notice I like to iterate for loops over the count and then use offsets for indexing. I find it easier to reason about my code this way, and I find operations are easier, but you could potentially change it if you want.

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

这篇关于VBA数据排序的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！