如何使用 VBA 將這些行值轉置為這種特定格式？

Question

我正在使用Excel 2016並且我是VBA的新手。 我有一個包含262行（沒有標題）的Excel工作表。 前2行的摘錄如下所示（從A列開始到L列結束）：

我想在工作表上運行 VBA 代碼來轉置數據，如下所示：

我該怎么辦？

Answer 1

一個特殊的轉置

Sub SpecialTranspose()

  Const cLngRows As Long = 262            ' Source Number of Rows
  Const cIntColumns As Integer = 6        ' Source Number of Columns Per Set
  Const cIntSets As Integer = 2           ' Source Number of Sets
  Const cStrSourceCell As String = "A1"   ' Source First Cell
  Const cStrTargetCell = "M1"             ' Target First Cell

  Dim vntSource As Variant  ' Source Array
  Dim vntTarget As Variant  ' Target Array

  Dim h As Integer  ' Source Array Set Counter / Target Array Column Counter
  Dim i As Long     ' Source Array Row Counter
  Dim j As Integer  ' Source Array Column Counter
  Dim k As Long     ' Target Array Row Counter

  ' Resize Source First Cell to Source Range and paste it into Source Array.
  vntSource = Range(cStrSourceCell).Resize(cLngRows, cIntColumns * cIntSets)

  ' Resize Target Array
  ReDim vntTarget(1 To cLngRows * cIntColumns, 1 To cIntSets)

  ' Calculate and write data to Target Array.
  For h = 1 To cIntSets
    For i = 1 To cLngRows
      For j = 1 To cIntColumns
        k = k + 1
        vntTarget(k, h) = vntSource(i, cIntColumns * (h - 1) + j)
      Next
    Next
  k = 0
  Next

  ' Paste Target Array into Target Range resized from Target First Cell.
  Range(cStrTargetCell).Resize(cLngRows * cIntColumns, cIntSets) = vntTarget

End Sub

Answer 2

您可以使用數組進行轉置：

Sub Transpose()

'Declare variables
Dim wsHome As Worksheet
Dim arrHome, arrNumber(), arrLetter() As Variant
Dim intNum, intLetter, lr, lc As Integer

Set wsHome = ThisWorkbook.Worksheets("Sheet1")
Set collNumber = New Collection
Set collLetter = New Collection

'Set arrays to position to 0
intNum = 0
intLetter = 0

'Finds last row and column of data
lc = Cells(1, Columns.Count).End(xlToLeft).Column
lr = Cells(Rows.Count, 1).End(xlUp).Row

'Move data into array
arrHome = wsHome.Range(Cells(1, 1), Cells(lr, lc)).Value

For x = LBound(arrHome, 1) To UBound(arrHome, 1)
    For y = LBound(arrHome, 2) To UBound(arrHome, 2)
        'Check if value is numeric
        If IsNumeric(arrHome(x, y)) = True Then
            ReDim Preserve arrNumber(intNum)
            arrNumber(intNum) = arrHome(x, y)
            intNum = intNum + (1)
        Else
            ReDim Preserve arrLetter(intLetter)
            arrLetter(intLetter) = arrHome(x, y)
            intLetter = intLetter + 1
        End If
    Next y
Next x

'clear all values in sheet
wsHome.UsedRange.ClearContents

ActiveSheet.Range("A1").Resize(UBound(arrNumber), 1).Value = Application.WorksheetFunction.Transpose(arrNumber)
ActiveSheet.Range("B1").Resize(UBound(arrLetter), 1).Value = Application.WorksheetFunction.Transpose(arrLetter)

End Sub

Answer 3

讓我們假設數據出現在工作表 1 中。嘗試：

Option Explicit

Sub TEST()

    Dim LastColumn As Long, LastRowList As Long, LastRowNumeric As Long, LastRowNonNumeric As Long, R As Long, C As Long

    With ThisWorkbook.Worksheets("Sheet1")

        LastRowList = .cells(.Rows.Count, "A").End(xlUp).Row
        LastColumn = .cells(1, .Columns.Count).End(xlToLeft).Column

        For R = 1 To LastRowList
            For C = 1 To LastColumn
                If IsNumeric(.cells(R, C).Value) = True Then
                    LastRowNumeric = .cells(.Rows.Count, LastColumn + 2).End(xlUp).Row
                    If LastRowNumeric = 1 And .cells(1, LastColumn + 2).Value = "" Then
                        .cells(LastRowNumeric, LastColumn + 2).Value = .cells(R, C).Value
                    Else
                        .cells(LastRowNumeric + 1, LastColumn + 2).Value = .cells(R, C).Value
                    End If
                Else
                    LastRowNonNumeric = .cells(.Rows.Count, LastColumn + 3).End(xlUp).Row
                    If LastRowNonNumeric = 1 And .cells(1, LastColumn + 3).Value = "" Then
                        .cells(LastRowNonNumeric, LastColumn + 3).Value = .cells(R, C).Value
                    Else
                        .cells(LastRowNonNumeric + 1, LastColumn + 3).Value = .cells(R, C).Value
                    End If
                End If
            Next C
        Next R

    End With

End Sub

Answer 4

嘗試

Sub test()
    Dim vDB, vR()
    Dim i As Long, j As Integer, n As Long
    Dim r As Long
    vDB = Range("a1").CurrentRegion
    r = UBound(vDB, 1)
    For i = 1 To r
        For j = 1 To 6
            n = n + 1
            ReDim Preserve vR(1 To 2, 1 To n)
            vR(1, n) = vDB(i, j)
            vR(2, n) = vDB(i, j + 6)
        Next j
    Next i
    Sheets.Add
    Range("a1").Resize(n, 2) = WorksheetFunction.Transpose(vR)

End Sub