Excel/VBA：转置和；齐平；桌子

我想自动化以下过程：

有一个数据表，我想转置

然后“向左冲” 随着时间的推移，行和列的数量将增加。下面的屏幕截图可以更好地解释（使用SkyDrive）：

---

我考虑这样做的唯一方法是使用

VBA

，通过

pastespecial transpose

和大量

do while

语句在复制之前找到行的开始和结束。我知道复制和粘贴会降低VBA程序的速度-有谁有更好的建议吗？

您可以使用

变体数组来实现这一点：

Sub Demo()
    Dim sh As Worksheet
    Dim rSource As Range
    Dim vSource As Variant

    Set sh = ActiveSheet
    ' set range to top left cell of table
    Set rSource = sh.Cells(1, 1) '<-- adjust to suit
    ' extend range
    '  this assumes there are no gaps in the top row or left column
    Set rSource = sh.Range(rSource.End(xlDown), rSource.End(xlToRight))
    With rSource
        ' remove Totals
        .Columns(.Columns.Count).Clear
        .Rows(.Rows.Count).Clear

        ' capture source data
        vSource = rSource
        ' clear old data
        rSource.Clear
        ' transpose and place data back
        sh.Range(.Cells(1, 1), .Cells(.Columns.Count, .Rows.Count)) = _
            Application.Transpose(vSource)
    End With
End Sub

子演示（）
将sh设置为工作表
作为范围的Dim rSource
Dim vSource作为变量
设置sh=ActiveSheet
'将范围设置为表格的左上角单元格
设置rSource=sh.Cells（1，1）“表格布局如下图所示。

电子表格示例：

输出列标题：
=偏移量（$B$2；C15；A16）
，从
C16
复制到右侧

输出行标题：
=偏移（$B$2；0；$A17）
，从
B17


辅助单元格：A列中的输出表数据行号，第15行中的数据列号

表格的数字部分可以使用
C17
中的单个公式构建，并向下和向右复制：

 =IF(B18="";"";OFFSET($B2;C$15;$A17))

Weeks列以“x”结尾，以获得第一个数据列的空白单元格

好-使用Chris的代码作为模板，在进行转置之前，有效地添加了两行额外的代码以消除空白：

Sub ThisWorks()

Dim sh As Worksheet
Dim rSource As Range
Dim vSource As Variant

Set sh = ActiveSheet
' set range to top left cell of table
Set rSource = sh.Cells(5, 3) '<-- adjust to suit
' extend range
'  this assumes there are no gaps in the top row or left column
Set rSource = sh.Range(rSource.End(xlDown), rSource.End(xlToRight))
With rSource
    ' remove Totals
    .Columns(.Columns.Count).Clear
    .Rows(.Rows.Count).Clear
End With
'reset rSource
Set rSource = sh.Range(rSource.End(xlDown), rSource.End(xlToRight))

With rSource
    ' delete the blanks - not as tricky as you mentioned in OP!!
    .SpecialCells(Excel.xlCellTypeBlanks).Delete Excel.xlUp
    ' capture source data
    vSource = rSource
    ' clear old data
    rSource.Clear
    ' transpose and place data back
    sh.Range(.Cells(1, 1), .Cells(.Columns.Count, .Rows.Count)) = Application.Transpose(vSource)
End With

End Sub

Sub ThisWorks（）
将sh设置为工作表
作为范围的Dim rSource
Dim vSource作为变量
设置sh=ActiveSheet
'将范围设置为表格的左上角单元格
Set rSource=sh.Cells（5，3）“我试图坚持使用数组（通常我喜欢相反的方式；-）只有数值被转置，用户进行选择。命名范围
“Vba\U输出”
应在图纸上预先定义

Sub Transpose_and_flush_table()

Dim source_array As Variant
Dim target_array As Variant
Dim source_column_counter As Long
Dim source_row_counter As Long
Dim blanks As Long

Const row_index = 1
Const col_index = 2

source_array = Selection.Value
' source_array(row,column)

ReDim target_array(UBound(source_array, col_index), UBound(source_array, row_index))

For source_column_counter = _
    LBound(source_array, col_index) To UBound(source_array, col_index)
       blanks = 0

      'Count blank cells
      For source_row_counter = _
         LBound(source_array, row_index) To UBound(source_array, row_index)
           If source_array(source_row_counter, source_column_counter) = "" Then
              blanks = blanks + 1
           End If
       Next

      'Replace blanks, shift array elements to the left
      For source_row_counter = _
         LBound(source_array, row_index) To UBound(source_array, row_index) - blanks
           source_array(source_row_counter, source_column_counter) = _
             source_array(source_row_counter + blanks, source_column_counter)
      Next

      'Add blanks to the end
      For source_row_counter = _
        UBound(source_array, row_index) - blanks + 1 To UBound(source_array, row_index)
           source_array(source_row_counter, source_column_counter) = ""
      Next

      'Transpose source and target arrays
      For source_row_counter = _
         LBound(source_array, row_index) To UBound(source_array, row_index)
             target_array(source_column_counter, source_row_counter) = _
            source_array(source_row_counter, source_column_counter)
      Next

Next

Range("Vba_output").Offset(-1, -1).Resize(UBound(target_array, row_index) + 1, _
  UBound(target_array, col_index) + 1) = target_array

End Sub

乍一看，没有VBA也可以实现同样的效果。你能上传这张桌子吗？只是想了想（一边喝茶：）-看看这两张桌子上的1685；在上表中，它位于Nov某物和Nov某物的交叉点；在所需的输出表中，它位于Oct某物和Nov某物的交叉点-您所做的似乎没有意义；或者你想把结果分为不同的几周**漂亮的代码，但我刚刚测试了它，结果似乎与OP结果集所需的模式不相似-您的代码与
Copy-Pastespecial相同；转置
但是用户正在寻找的转置更复杂。+1除非我必须使用VBA，否则我将遵循这个示例-
偏移
是一个很好的功能。
Sub Transpose_and_flush_table()

Dim source_array As Variant
Dim target_array As Variant
Dim source_column_counter As Long
Dim source_row_counter As Long
Dim blanks As Long

Const row_index = 1
Const col_index = 2

source_array = Selection.Value
' source_array(row,column)

ReDim target_array(UBound(source_array, col_index), UBound(source_array, row_index))

For source_column_counter = _
    LBound(source_array, col_index) To UBound(source_array, col_index)
       blanks = 0

      'Count blank cells
      For source_row_counter = _
         LBound(source_array, row_index) To UBound(source_array, row_index)
           If source_array(source_row_counter, source_column_counter) = "" Then
              blanks = blanks + 1
           End If
       Next

      'Replace blanks, shift array elements to the left
      For source_row_counter = _
         LBound(source_array, row_index) To UBound(source_array, row_index) - blanks
           source_array(source_row_counter, source_column_counter) = _
             source_array(source_row_counter + blanks, source_column_counter)
      Next

      'Add blanks to the end
      For source_row_counter = _
        UBound(source_array, row_index) - blanks + 1 To UBound(source_array, row_index)
           source_array(source_row_counter, source_column_counter) = ""
      Next

      'Transpose source and target arrays
      For source_row_counter = _
         LBound(source_array, row_index) To UBound(source_array, row_index)
             target_array(source_column_counter, source_row_counter) = _
            source_array(source_row_counter, source_column_counter)
      Next

Next

Range("Vba_output").Offset(-1, -1).Resize(UBound(target_array, row_index) + 1, _
  UBound(target_array, col_index) + 1) = target_array

End Sub