1

次のような Excel ファイルが
あり
ます
。

シートにある各行の 3 つ (または任意の数) のコピーを作成するにはどうすればよいですか? 行をコピーした後に追加したいのですが? So, in the end i would like to have this kind of a result:
row1_cell1 row1_cell2 row1_cell3
row1_cell1 row1_cell2 row1_cell3 row1_cell1 row1_cell2 row1_cell3 row2_cell1 row2_cell2 row2_cell3 row2_cell1
row2_cell2 row2_cell3 row2_cell1
row2_cell2 row2_cell3
row3_cell1 row3_cell2
row3_cell3
row3_cell1 row3_cell2
row3_cell3
row3_cell1 row3_cell2 row3_cell3

4

3 に答える 3

1

これは、シートのすべての行に対してこれを行う方法です。

Option Explicit

Sub MultiplyRows()
Dim RwsCnt As Long, LR As Long, InsRw As Long

RwsCnt = Application.InputBox("How many copies of each row should be inserted?", "Insert Count", 2, Type:=1)    
If RwsCnt = 0 Then Exit Sub
LR = Range("A" & Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False
For InsRw = LR To 1 Step -1
    Rows(InsRw).Copy
    Rows(InsRw + 1).Resize(RwsCnt).Insert xlShiftDown
Next InsRw
Application.ScreenUpdating = True

End Sub
于 2012-06-29T13:50:04.617 に答える
0

希望どおりにインターリーブして貼り付ける直接的な方法はありません。ただし、一時的な VBA を作成して、必要なことを行うことができます。

たとえば、次のことができます。

  1. Excel ファイルに VBA プロシージャ (以下のようなもの) を作成します。
  2. それにキーボード ショートカット (例: Ctrl+Q) を割り当てます。
    • これを行うには、Alt+F8 を押してマクロを選択し、[オプション] をクリックします。
  3. コピーするセルを選択し、Ctrl+C を押します。
  4. 貼り付けたいセルを選択し、Ctrl+Q (または任意のキーボード ショートカット) を押します。
  5. コピーする回数を入力します。(あなたの例では、それは 3 になります。)
  6. ワモ！:D
  7. これで、VBA プロシージャを削除できます。:)

VBA コード:

Sub PasteAsInterleave()
    Dim startCell As Range
    Dim endCell As Range
    Dim firstRow As Range
    Dim pasteCount As Long
    Dim rowCount As Long
    Dim colCount As Long
    Dim i As Long
    Dim j As Long
    Dim inputValue As String

    If Application.CutCopyMode = False Then Exit Sub

    'Get number of times to copy.
    inputValue = InputBox("Enter number of times to paste interleaved:", _
                 "Paste Interleave", "")
    If inputValue = "" Then Exit Sub  'Cancelled by user.

On Error GoTo Error
    pasteCount = CInt(inputValue)
    If pasteCount <= 0 Then Exit Sub
On Error GoTo 0

    'Paste first set.
    ActiveSheet.Paste
    If pasteCount = 1 Then Exit Sub

    'Get pasted data information.
    Set startCell = Selection.Cells(1)
    Set endCell = Selection.Cells(Selection.Cells.count)
    rowCount = endCell.Row - startCell.Row + 1
    colCount = endCell.Column - startCell.Column + 1
    Set firstRow = Range(startCell, startCell.Offset(0, colCount - 1))

    'Paste everything else while rearranging rows.
    For i = rowCount To 1 Step -1
        firstRow.Offset(i - 1, 0).Copy

        For j = 1 To pasteCount
            startCell.Offset(pasteCount * i - j, 0).PasteSpecial
        Next j
    Next i

    'Select the pasted cells.
    Application.CutCopyMode = False
    Range(startCell, startCell.Offset(rowCount * pasteCount - 1, colCount - 1)).Select
    Exit Sub

Error:
    MsgBox "Invalid number."
End Sub
于 2012-06-29T06:41:03.960 に答える