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

Question

我想自动化以下过程：

1. 有一个数据表格，我想转置它。
2. 然后“左对齐”。

随着时间的推移，行数和列数将增加。下面的屏幕截图应该更好地解释（使用SkyDrive）：http://sdrv.ms/UdDu1o 我能想到的唯一方法是使用VBA，通过pastespecial-transpose和大量的do-while语句来查找复制前的行的开头和结尾。我知道复制和粘贴会减慢VBA程序的速度-是否有更好的建议？

- wasabigeek

---

乍一看，也可以在没有VBA的情况下实现相同的效果。您能上传表格本身吗？ - Jüri Ruut

刚有个想法（当我吃晚饭的时候 :)) - 看看两个表中的_1685_；在顶部表格中，它位于_11月某个日期_和_11月某个日期_的交叉点处；在期望输出表中，它位于_10月某个日期_和_11月某个日期_的交叉点处 - 你所做的似乎没有意义；或者你是想把结果移到不同的周？** - whytheq

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

周数列以“x”结尾，以得到一个空单元格，使第一列数据正确显示。

- Jüri Ruut

---

除非我必须使用VBA，否则我会遵循这个例子 - OFFSET是一个很棒的函数。 - whytheq

Answer 2

您可以使用变量数组轻松实现此操作：

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

- chris neilsen

---

代码写得很好，但我刚刚测试了一下，结果似乎与 OP 结果集的期望模式不太相似 - 你的代码与“复制-特殊粘贴；转置”做的一样，但用户寻找的转置更加复杂。 - whytheq

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

- whytheq

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

- Jüri Ruut