重复转置标头

• 它将打开选定的文件并将数据复制到新创建的单工作表工作簿。首先，按原样测试并调整数字。如果前面的代码未在此处发布，请将创建工作簿的行移动到代码的开头，并使用dwb（和dws）而不是（激活）Windows("Book1")。

Sub TransposeHeaders()
     
    Const dReps As Long = 358

    ' Open the source file.
    Dim sPath: sPath = Application.GetOpenFilename( _
        Filefilter:="Excel Files (*.xls*), *.xls*", Title:="Select FIles")
    If VarType(sPath) = vbBoolean Then
        MsgBox "No file selected.", vbExclamation
        Exit Sub
    End If

    ' Write the values from the source worksheet to the source array.
    Dim swb As Workbook: Set swb = Workbooks.Open(sPath)
    Dim sws As Worksheet: Set sws = swb.Worksheets(1) ' adjust e.g. "Sheet1"
    Dim srg As Range
    Set srg = sws.Range("B3", sws.Cells(3, sws.Columns.Count).End(xlToLeft))
    Dim sData(): sData = srg.Value
    
    ' Write the values from the source to the destination array.
    
    Dim scCount As Long: scCount = srg.Columns.Count
    Dim dData(): ReDim dData(1 To scCount * dReps, 1 To 1)
    
    Dim sValue, sc As Long, dRep As Long, dr As Long
    
    For sc = 1 To scCount
        sValue = sData(1, sc)
        For dRep = 1 To dReps
            dr = dr + 1
            dData(dr, 1) = sValue
        Next dRep
    Next sc
    
    ' Write the values from the destination array to the destination range.
    
    ' Add and reference a new single-worksheet workbook.
    Dim dwb As Workbook: Set dwb = Workbooks.Add(xlWBATWorksheet)
    ' Reference its only worksheet.
    Dim dws As Worksheet: Set dws = dwb.Sheets(1) ' the one and only
    ' Reference the destination range.
    Dim dfCell As Range: Set dfCell = dws.Range("C2")
    Dim drg As Range: Set drg = dfCell.Resize(dr)
    ' Write the values from the destination array to the destination range.
    drg.Value = dData
    
    ' Close the source workbook.
    swb.Close SaveChanges:=False

End Sub

下面是一些注解代码，可以帮助您理解如何编写所需的内容：

Sub ImportData()
    
    'Import data from StartCol to FinalCol, from CopyRow, a total of CopyTimes
    Const sStartCol As String = "B"
    Const sFinalCol As String = "BK"
    Const lCopyRow As Long = 3
    Const lCopyTimes As Long = 358
    
    'Data imported will be placed in DestCol
    Const sDestCol As String = "C"
    
    'Option to clear previous data before importing
    'Set this to false if you want to keep prior data
    Const bClearPrevious As Boolean = True
    
    'Declare and define destination variables
    Dim wbDest As Workbook:     Set wbDest = ThisWorkbook
    Dim wsDest As Worksheet:    Set wsDest = wbDest.Worksheets("Sheet1")    'Set this to correct worksheet in destination workbook
    
    'Prompt for source file
    Dim sSourceFile As String
    sSourceFile = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , "Select Import File", MultiSelect:=False)
    If sSourceFile = "False" Then Exit Sub  'Pressed cancel
    
    'Clear previous results if option is set to true
    If bClearPrevious = True Then wsDest.Range(sDestCol & 2, wsDest.Cells(wsDest.Rows.Count, sDestCol).End(xlUp)).ClearContents
    
    Dim lColIndex As Long
    Dim sSourceSheet as String
    With Workbooks.Open(sSourceFile)
        'Specify correct worksheet for the source workbook names here
        Select Case .Name
            Case "Book1.xlsx": sSourceSheet = "Sheet1"
            Case "Book2.xlsx": sSourceSheet = "Sheet10"
            Case "Book3.xlsx", "Book4.xlsx": sSourceSheet = "DataSheet"
            Case Else: sSourceSheet = "Sheet1" 'If the other cases aren't found, it will default to the Case Else
        End Select
        With .Worksheets(sSourceSheet)
        
            For lColIndex = .Columns(sStartCol).Column To .Columns(sFinalCol).Column
                wsDest.Cells(wsDest.Rows.Count, sDestCol).End(xlUp).Offset(1).Resize(lCopyTimes).Value = .Cells(lCopyRow, lColIndex).Value
            Next lColIndex
            
        End With
        .Close False    'Close source file, don't save changes
    End With
    
End Sub