4

次のプロセスを自動化したいと思います。

  1. 転置したいデータの表があります。
  2. 次に「左にフラッシュ」します。

行と列の数は、時間が経つにつれて増加します。以下のスクリーンショットは（SkyDriveを使用して）よりよく説明するはずです：http ：//sdrv.ms/UdDu1o

ここに画像の説明を入力してください

これを行うことについて私が考えることができる唯一の方法は、コピーする前にVBA、viapastespecial-transposeと多くのステートメントを使用して行の開始と終了を見つけることでした。do-whileコピーアンドペーストはVBAプログラムの速度を低下させる傾向があることを理解しています-誰かより良い提案がありますか？

4

4 に答える 4

3

テーブルレイアウトは下の画像にあります。
スプレッドシートの例: 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」で終了し、最初のデータ列に空白のセルを取得します。

スクリーンショット:

于 2012-12-29T15:41:01.747 に答える
1

ok-Chrisのコードをテンプレートとして使用し、転置を行う前に空白を取り除くために2行のコードを効果的に追加しました。

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
于 2012-12-29T15:44:11.160 に答える
1

を使用して、これを非常に簡単に実現できます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
于 2012-12-29T09:01:45.023 に答える
0

私は配列に固執しようとしました (通常、私はその逆が好きです ;-) 数値のみが転置され、ユーザーが選択を行います。名前付き範囲"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
于 2012-12-29T18:39:31.627 に答える