VBA сортировка данных

лист1
лист2

Проблема, с которой я сталкиваюсь, заключается в том, что иногда все заголовки и значения данных отсутствуют в наборе данных, и поэтому, используя последнюю строку в скрипте, данные сдвигаются на единицу. Например, если я полностью удалил H11:H12 на листе 1, то значения для столбца H, связанного с набором данных в A11:K11, фактически будут из набора данных A13: K13 (или значение ячейки H14).

Пробелы, показанные во втором изображении, не будут присутствовать, если соответствующий заголовок отсутствует.

Вопрос: учитывая следующий код; как вы думаете, возможно ли сопоставить данные с заголовками и использовать исходный номер строки смещения рядом со столбцом, с которым он сопоставлен на листе 2, и вставить туда значения? Вместо этого текущий код (и только метод, который работал, должен был найти последнюю строку).

Примеры / Мысли:
Я думаю, что сценарий должен будет взять ячейку (например, D9 и распознает, что это D и смещения, чтобы выбрать D10 и соответствует, что запись D9 на лист 2 столбец D и вставляет данные D10 в D10, а не D5.

во втором примере скрипт берет I17 и распознает, что он соответствует столбцу I листа 2, а затем смещает выбор/копирование и вставляет данные 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

Дополнение:
Введите описание изображения здесь

Кажется, есть исключение, которое предотвращает копирование этих значений ячеек, если я сделаю это вручную, приведенный ниже скриншот будет правильным. Есть советы по диагностике?

Введите описание изображения здесь

Очень странно, потому что линия с красной точкой копирует отлично в обоих, но эти четыре линии, кажется, не.

2 ответа

  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
    

    Используйте сценарий.Словарь скриптов.Dictionarys для отслеживания возможно различных пар строк длины заголовков / данных. описание.Словарь заголовков позволяет добавлять новые заголовки по мере их появления. Вложенные Скрипты.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
    
  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