Упорядочить данные заголовка VBA

Question

Я работаю над листом данных с несколькими заголовками, и я хотел бы расположить каждый заголовок в определенном столбце.

Моя проблема сейчас заключается в том, что у меня есть несколько заголовков по строкам, и я могу расположить заголовки только по первому набору заголовков в первом ряду, а не во всех строках.

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

Код, который я использую сейчас, который позволяет мне толькоупорядочить столбцы по первому ряду столбцов выглядит следующим образом:

Sub CopyHeadersColumns()

'Set the column heading you want. Add as many as you want, comma seperated
'The order you enter determines the order they appear on the second sheet
Dim Titles As Variant
Titles = Array("/@codeInsee", "/Nom", "/CoordonnéesNum/Télécopie", "/CoordonnéesNum/Téléphone", "/Ouverture/PlageJ/@début", "/Ouverture/PlageJ/@fin", "/Ouverture/PlageJ/PlageH/@début", "/Ouverture/PlageJ/PlageH/@fin")

Dim i As Long 'Counter

For i = 0 To UBound(Titles)

    'Select Full Report Sheet
    Sheets(1).Select

    'Find Notes column and copy. If it can't find the title, will move to the next.
    On Error GoTo ErrHandler
        Cells.Find(What:=Titles(i), After:=Range("A1"), _
        LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns).EntireColumn.Copy
    On Error GoTo 0

    'Select Secondary Report sheet, column E and paste
    Sheets(2).Select
    Range("A1").Offset(0, i).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False

NextOne:
Next i

Exit Sub

ErrHandler:
Resume NextOne

End Sub

Answer 1

Если у вас уже есть заголовки в качестве заголовков для столбцов на втором листе, пожалуйста, посмотрите, помогает ли это, я добавил комментарии в коде для более подробной информации:

Option Explicit

Sub CopyHeadersColumns()

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

With ActiveWorkbook
    Dim wsSrc As Worksheet: Set wsSrc = .Sheets("Sheet1")
    Dim wsDst As Worksheet: Set wsDst = .Sheets("Sheet2")
End With

Dim arrTitles As Variant
arrTitles = Array("/@codeInsee", "/Nom", "/CoordonnéesNum/Télécopie", "/CoordonnéesNum/Téléphone", "/Ouverture/PlageJ/@début", "/Ouverture/PlageJ/@fin", "/Ouverture/PlageJ/PlageH/@début", "/Ouverture/PlageJ/PlageH/@fin")

Dim arrData As Variant, arrDstTitles As Variant, arrCols() As Long
Dim R As Long, C As Long, X As Long, Y As Long, lRowSrc As Long, lColSrc As Long, lRowDst As Long

arrDstTitles = wsDst.Cells(1, 1).Resize(1, wsDst.Cells(1, Columns.Count).End(xlToLeft).Column)

Dim dicTitles As Object
Set dicTitles = CreateObject("Scripting.Dictionary")

'Allocate the column number of the destination title to the dictionary for reuse
For X = LBound(arrTitles) To UBound(arrTitles)
    For Y = LBound(arrDstTitles, 2) To UBound(arrDstTitles, 2)
        If arrTitles(X) = arrDstTitles(1, Y) Then
            dicTitles(arrTitles(X)) = Y
            Exit For
        End If
    Next Y
Next X


With wsSrc
    lRowSrc = .UsedRange.Rows.Count 'get the last row in the source worksheet
    lColSrc = .UsedRange.Columns.Count 'get the last column in the source worksheet
    arrData = .Cells(1, 1).Resize(lRowSrc, lColSrc) 'get the data into an array

    For R = LBound(arrData) To UBound(arrData)
        For C = LBound(arrData, 2) To UBound(arrData, 2)
            'Check if row is a title
            If dicTitles.Exists(arrData(R, C)) Then 'title found
                If X <> R Then ReDim arrCols(1 To lColSrc) 'redimensionate the array to hold the column number of the destination
                X = R 'save the row of the title
                arrCols(C) = dicTitles(arrData(R, C))
            ElseIf Not X = R And Not IsEmpty(arrData(R, C)) And Not arrCols(C) = 0 Then
                With wsDst
                    If C = 1 Then lRowDst = .Cells(Rows.Count, 1).End(xlUp).Row + 1
                    .Cells(lRowDst, arrCols(C)).Value = arrData(R, C)
                End With
            End If
        Next C
    Next R
End With

With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With

End Sub

РЕДАКТИРОВАТЬ: изменил код на основе нового ввода из OP.