Question

我想自动执行以下过程：

我想要移植一个数据表。
然后“向左冲”。

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

enter image description here

我能想到这样做的唯一方法是使用VBA，通过pastespecial-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))

“周”列以“x”结束，以获取第一个数据列的空白单元格。

Screenshot:

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

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

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

4 个答案: