excel - xlascending - VBA數據排序




vba篩選排序 (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

我遇到的問題是,有時整個標題和數據值在數據集中丟失,因此使用腳本中的最後一行數據向上移動一個。 例如,如果我在sheet1上完全刪除H11:H12,那麼與A11:K11中的數據集關聯的H列的值實際上將來自數據集A13:K13(或單元格值H14)。

如果相應的標題不存在,則第二圖像中顯示的空格將不存在。

問題:給出以下代碼; 您認為可以將數據與標題匹配,並使用原始偏移行號與列表2上的列匹配,並將值粘貼到那裡? 相反,當前的代碼(只有方法是找到最後一行)。

示例/想法:我想腳本將不得不採取一個單元格(如D9,並認識到它是一個D和偏移量選擇D10和匹配D9記錄到表2列D和粘貼D10數據在D10比D5。

第二個例子,腳本採取I17,並認識到它匹配I到表2列I,然後偏移選擇/複製和粘貼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

加成:

似乎有一個例外,防止這些細胞值被複製,如果我手動做下面的截圖是正確的。 任何提示來診斷?

非常奇怪,因為與紅點複製在兩個罰款,但這四條線似乎失敗。


為了後代的緣故,我將我以前的答复留下,但是現在你已經澄清了你的問題,我有一個更好的答案給你。

我將假設如下: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.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




sorting