Excel VBA - 仅转置为值[重复]

当您的代码达到预期效果后，此更改将仅粘贴“值”和“数字”格式。
请使用PasteSpecial并粘贴“值”和“数字”格式。

注意MyTime，MyDate和MyStr都被声明为变体。

Sub transpLeagueTable()

    Dim targetrow  As Long
    Dim i As Long

    Dim MyTime, MyDate, MyStr
    targetrow = 6
    For i = 8 To ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
        ActiveSheet.Range("A" & i & ":A" & i & ",C" & i & ":J" & i).Copy 'Worksheets("League Table CSV").Cells(targetrow, 2 + (i - 8) * 9)
        Worksheets("League Table CSV").Cells(targetrow, 2 + (i - 8) * 9).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    Next i
    Columns("A:A").EntireColumn.Hidden = False
    Application.GoTo Sheets("League Table CSV").Range("A6"), True
    
    Columns("A:A").EntireColumn.Hidden = True
    
    Application.CutCopyMode = False
    Application.GoTo Sheets("League Table CSV").Range("B6"), True

End Sub

不要复制/粘贴；直接传输值，而是使用Range.Value或Range.Formula2（取决于您是否只想要计算值，或者也保留公式）。

Option Explicit

Sub transpLeagueTable()
    'Pick one, depending on your use-case
    'Const targetrow As Long = 6
    Dim targetrow As Long: targetrow = 6
    
    Dim i As Long, j As Long, MaxRow As Long
    Dim rSource As Range, rDest As Range, WorkingArea As Range
    
    MaxRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    
    If MaxRow >= 8 Then
        Set rSource = ActiveSheet.Range("A8:A" & MaxRow & ",C8:J" & MaxRow)
        Set rDest = ActiveWorkbook.Worksheets("League Table CSV").Cells(targetrow, 2).Resize(rSource.Rows.Count, 1)
        
        For Each WorkingArea In rSource
            Set rDest = rDest.Resize(, WorkingArea.Columns.Count)
            
            'rDest.Formula2 = WorkingArea.Formula2
            rDest.Value = WorkingArea.Value
            
            Set rDest = rDest.Resize(, 1).Offset(0, WorkingArea.Columns.Count)
        Next WorkingArea
        
        Set WorkingArea = Nothing
        Set rSource = Nothing
        Set rDest = Nothing
    End If
    
    ActiveSheet.Columns(1).Hidden = False
    
    With ActiveWorkbook.Worksheets("League Table CSV")
        Application.GoTo .Range("B6"), True
        .Columns(1).EntireColumn.Hidden = True
    End With
End Sub

（请注意，如果您没有跳过 B 列，那么您甚至不需要循环：类似的操作ActiveWorkbook.Worksheets("League Table CSV").Range("A1:C7").Value = ActiveSheet.Range("A8:C14").Value会直接执行）

复制表格行

• 将 Excel 表格中每一行的特定单元格（列）复制到另一张表上的一行，例如Sheet1!A8:A9,C8:J9（Sheet2!B6:S62 行 9 个单元格到 1 行 18 个单元格）。

Sub PQDataToLeagueTable()
     
    ' Define constants.
    Dim COPY_COLUMNS() As Variant: COPY_COLUMNS = VBA.Array( _
        1, 3, 4, 5, 6, 7, 8, 9, 10)
    
    ' Reference the workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the source sheet and return the values of the source table
    ' in a 2D one-based array, the source array,
    Dim sws As Worksheet: Set sws = wb.ActiveSheet ' could be the wrong one!
    ' Improve with e.g.:
    'Dim sws As Worksheet: Set sws = wb.Sheets("PP Sheet")
    If sws.ListObjects.Count = 0 Then
        MsgBox "Sheet """ & sws.Name & """ has no tables!", vbExclamation
        Exit Sub
    End If
    Dim sData() As Variant: sData = sws.ListObjects(1).DataBodyRange.Value
    
    ' Store the number of rows and columns in variables.
    Dim sRowsCount As Long: sRowsCount = UBound(sData, 1)
    Dim cColumnsCount As Long: cColumnsCount = UBound(COPY_COLUMNS) + 1
    Dim tColumnsCount As Long: tColumnsCount = sRowsCount * cColumnsCount
    
    ' Define the target array, a 1D one-based ('single-row') array.
    Dim tArr() As Variant: ReDim tArr(1 To tColumnsCount)
    
    ' Declare additional variables introduced in the following loop.
    Dim sRow As Long, sCol As Long, cCol As Long, tCol As Long
    
    ' Loop through the rows, then columns of the source array
    ' copying each value to the target array.
    For sRow = 1 To sRowsCount
        For cCol = 1 To cColumnsCount
            tCol = tCol + 1
            sCol = COPY_COLUMNS(cCol - 1)
            tArr(tCol) = sData(sRow, sCol)
        Next cCol
    Next sRow
    
    ' Reference the target worksheet, first cell
    ' and (build the) single-row range.
    Dim tws As Worksheet: Set tws = wb.Sheets("League Table CSV")
    Dim tcell As Range: Set tcell = tws.Range("B6")
    Dim trg As Range: Set trg = tcell.Resize(, tColumnsCount)
    
    ' Copy the values from the target array to the target range.
    trg.Value = tArr

    ' Select and scroll to the first target cell.
    Application.GoTo tcell, True

End Sub