1

500k以上の大きなファイルを受信して​​いますが、すべてのコンテンツが列Aにあります。データをマトリックス形式に転置するマクロを実行する必要がありますが"KEY*"、ActiveCellで見つかった場合にのみ新しい行が作成されます。例えば：

| KEY 4759839 | asljhk | 35049 | | sklahksdjf|
| KEY 359     | skj    | 487   |y| 2985789   |

私のファイルの上記のデータは、元々A列で次のようになります。

KEY 4759839
asljhk
35049

sklahksdjf
KEY 359
skj
487
y
2985789

考慮事項：

  • 空白のセルも転置する必要があるため、emptyCellに基づいてマクロを停止することはできません
  • KEY間のセルの数は一定ではないため、実際にセルを読み取って、新しい行を作成する必要があるかどうかを確認する必要があります。
  • たとえば、行の20個の空のセルに基づいて停止するか、最大行数の入力を求めることができます。
  • （オプション）行の最後のアイテムに何らかの視覚的なインジケーターがあり、最後のアイテムが空白のセルであるかどうかを判断できると便利です。

調べてみると、同じ一般的なテーマのマクロが見つかりましたが、6行ごとに基づいており、自分の場合に合わせて変更するのに十分な知識がありませんでした。しかし、ここで役立つ場合は、次のようになります。

Sub kTest()
    Dim a, w(), i As Long, j As Long, c As Integer
    a = Range([a1], [a500000].End(xlUp))
    ReDim w(1 To UBound(a, 1), 1 To 6)
    j = 1
    For i = 1 To UBound(a, 1)
        c = 1 + (i - 1) Mod 6: w(j, c) = a(i, 1)
        If c = 6 Then j = j + 1
    Next i
    [c1].Resize(j, 6) = w
End Sub

私はあなたが私に与えることができるどんな助けでも大いに感謝します！

4

2 に答える 2

2

これは、質問で提供したサンプルデータで機能します。結果はB1で始まるテーブルに出力されます。私のマシンでは、500k行で1秒未満で実行されます。

Sub kTest()
    Dim originalData As Variant
    Dim result As Variant
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim countKeys As Long
    Dim countColumns As Long
    Dim maxColumns As Long

    originalData = Range([a1], [a500000].End(xlUp))

    countKeys = 0
    maxColumns = 0

    'Calculate the number of lines and columns that will be required
    For i = LBound(originalData, 1) To UBound(originalData, 1)
        If Left(originalData(i, 1), 3) = "KEY" Then
            countKeys = countKeys + 1
            maxColumns = IIf(countColumns > maxColumns, countColumns, maxColumns)
            countColumns = 1
        Else
            countColumns = countColumns + 1
        End If
    Next i

    'Create the resulting array
    ReDim result(1 To countKeys, 1 To maxColumns) As Variant

    j = 0
    k = 1
    For i = LBound(originalData, 1) To UBound(originalData, 1)
        If Left(originalData(i, 1), 3) = "KEY" Then
            j = j + 1
            k = 1
        Else
            k = k + 1
        End If
        result(j, k) = originalData(i, 1)
    Next i

    With ActiveSheet
        .Cells(1, 2).Resize(UBound(result, 1), UBound(result, 2)) = result
    End With

End Sub
于 2012-05-10T15:06:43.167 に答える
1

テストされ、動作します： 

    Sub test()
    Row = 0
    col = 1

    'Find the last not empty cell by selecting the bottom cell and moving up
    Max = Range("A650000").End(xlUp).Row 'Or whatever the last allowed row number is

    'loop through the data
    For i = 1 To Max
        'Check if the left 3 characters of the cell are "KEY" and start a new row if they are
        If (Left(Range("A" & i).Value, 3) = "KEY") Then
             Row = Row + 1
             col = 1
        End If

        Cells(Row, col).Value = Range("A" & i).Value
        If (i > Row) Then
            Range("A" & i).Value = ""
        End If
        col = col + 1

    Next i
End Sub
于 2012-05-10T15:01:09.203 に答える