Excel / VBA：移调和“刷新”表

我想自动化以下过程：

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

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

我唯一能想到的就是使用VBA ，通过pastespecial-transpose和大量的do-while语句在复制之前find行的开始和结束。 我明白复制和粘贴往往会减慢VBA程序 – 有没有人有更好的build议？

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的单个公式构build，向下复制到右侧：

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

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

Answer 2

你可以很简单地使用Variant Array来实现这个function：

 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分钟把我的头撞到了一堵砖墙上 – 我试图把所有的值join到一个数组中，然后把它们清空，以便顺序是正确的。 如果你能看到如何让下面的工作，请让我知道，我相信这是可能的！

 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

我试图坚持数组（通常我喜欢它相反;-)只有数字值转置，用户进行select。 应在工作表上预先定义一个命名范围"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