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的新输入更改了代码。

安排标题的数据VBA

1 个答案: