根据多行标题重新排列数据

Question

我有一个带有多个多行标题和数据的合并文件。我想排列数据，以便在同一列中具有相同的标题和标题的数据。

我以前尝试过排列列，但是由于文件处于只读状态，所以我遇到了无法解决的错误。

在下面的链接中，您将找到合并数据的图像，标题将显示为浅灰色。 enter image description here

这是我的合并代码

 Sub Merger()
Dim bookList As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
Application.ScreenUpdating = False
Set mergeObj = CreateObject("Scripting.FileSystemObject")


Set dirObj = mergeObj.Getfolder("Path")  'PATH
Set filesObj = dirObj.Files
For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)


Range("A2:IV" & Range("A65536").End(xlUp).Row).Copy                                         'A65536 is the last row for Colmn A
ThisWorkbook.Worksheets(1).Activate


Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
Application.CutCopyMode = False
bookList.Close
Next
End Sub

复制标题代码

Sub CopyHeaders() 
Dim r As Range
Dim ar As Variant
Dim i As Integer
Dim fn As Range
Dim str As String

'Array Values
ar = Array("/@codeInsee", "/CoordonnéesNum/Télécopie", "/CoordonnéesNum/Téléphone", "/Nom", "/Ouverture/PlageJ/@début", "/Ouverture/PlageJ/@fin", "/Ouverture/PlageJ/PlageH/@début", "/Ouverture/PlageJ/PlageH/@fin")
For i = 0 To UBound(ar) 'Loop Array
Set fn = [A1:AW1].Find(ar(i), lookat:=xlWhole)
str = str & fn.Address & ","
Next i 
str = Left(str, Len(str) - 1)
Set r = Range(str).EntireColumn
r.Copy ThisWorkbook.Sheets(2).[a2] 'Copy and Paste to new sheet in cell A2.
End Sub