vba - Excel/VBA：转置和“刷新”表

Question

我想自动化以下过程：

1. 有一个我想要转置的数据表。
2. 然后“向左冲洗”。

随着时间的推移，行数和列数会增加。下面的屏幕截图应该更好地解释（使用 SkyDrive）：http ://sdrv.ms/UdDu1o

我能想到的唯一方法是在复制之前使用VBA、 viapastespecial-transpose和许多do-while语句来查找行的开头和结尾。我了解复制和粘贴往往会减慢 VBA 程序的速度 - 有人有更好的建议吗？

Answer 1

表格布局如下图所示。
电子表格示例：http ://www.bumpclub.ee/~jyri_r/Excel/Transpose_and_flush_data.xls

输出列标题：=OFFSET($B$2;C15;$A16)，从 复制到右侧C16。
输出行标题：=OFFSET($B$2;0;$A17)，从辅助单元格中复制下来B17
：在 A 列中输出表格数据行号，在第 15 行中输出数据列号。

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

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

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

Answer 2

您可以使用以下方法非常简单地实现此目的Variant Array：

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

Answer 3

好的 - 已经使用 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

在执行上述操作之前，我花了 90 分钟将头撞在砖墙上——我尝试将所有值添加到一个数组中，然后以正确的顺序将它们清空。如果你能看到如何让以下工作，请让我知道，因为我相信这是可能的！......

Option Explicit
Option Base 1

Sub ThisDoesNOTwork()

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))

Dim tableWidth As Integer
tableWidth = rSource.Rows.Count

Dim numbers() As Variant
ReDim numbers(rSource.Cells.Count)

'add numbers into the array
Dim x, y, z As Integer
z = 1
For y = 1 To rSource.Columns.Count
    For x = 1 To rSource.Rows.Count
            numbers(z) = rSource(x, y)
            z = z + 1
    Next
 Next

' clear old data
rSource.Clear

'empty the array
Dim myValue
Dim i As Integer
Dim blanks As Integer
i = 0
blanks = 0

Dim c As Integer
For c = 1 To UBound(numbers)

        i = i + 1
        If numbers(i) = "" Then
            blanks = blanks + 1
        Else
            rSource.Cells(i) = numbers(c)
        End If

Next c
Debug.Print blanks

End Sub

Answer 4

我试图坚持使用数组（通常我喜欢反过来;-) 只有数值被转置，用户进行选择。"Vba_output"应在工作表上预先定义命名范围。

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