1つのセルから複数のセルへのExcel VBAマクロ

Question

このマクロは、一度に1つのセルに適用する（または複数の行にドラッグすると、一番左上のセルの行に作用します）場合に機能します。ユーザーが一括して行を変更できるように、選択したすべてのセルの行に変更を適用するマクロを取得するために、それをさらに微調整する方法はありますか？

最後に8行に1つの行を分割するマクロを記録しましたcolumns J:Q ロジックは、選択されたセル（マージ対象のセルの下に存在する）の上に7行挿入し、 columns A:I

のためのオリジナルの既存の行と行は、これは私にA:Iのための1つのセルと、私はこのコードのより多くの意味を理解し、ずっとそれを作るためにいくつかの調整を行った

*See macro below 



Sub splitrowsandmerge() 
' 
' splitrowsandmerge Macro 
' add 7 rows and merge 8 rows for first 9 columns 
' 
' Keyboard Shortcut: Ctrl+Shift+E 
' 
ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select 
Selection.Insert Shift:=xlDown 
Selection.Insert Shift:=xlDown 
Selection.Insert Shift:=xlDown 
Selection.Insert Shift:=xlDown 
Selection.Insert Shift:=xlDown 
Selection.Insert Shift:=xlDown 
Selection.Insert Shift:=xlDown 
ActiveCell.Offset(-1, 0).Range("A1:A8").Select 
With Selection 
    .HorizontalAlignment = xlCenter 
    .VerticalAlignment = xlTop 
    .WrapText = True 
    .Orientation = 0 
    .AddIndent = False 
    .IndentLevel = 0 
    .ShrinkToFit = False 
    .ReadingOrder = xlContext 
    .MergeCells = False 
End With 
Selection.Merge 
ActiveCell.Offset(0, 1).Range("A1:A8").Select 
With Selection 
    .HorizontalAlignment = xlCenter 
    .VerticalAlignment = xlTop 
    .WrapText = True 
    .Orientation = 0 
    .AddIndent = False 
    .IndentLevel = 0 
    .ShrinkToFit = False 
    .ReadingOrder = xlContext 
    .MergeCells = False 
End With 
Selection.Merge 
ActiveCell.Offset(0, 1).Range("A1:A8").Select 
With Selection 
    .HorizontalAlignment = xlCenter 
    .VerticalAlignment = xlTop 
    .WrapText = True 
    .Orientation = 0 
    .AddIndent = False 
    .IndentLevel = 0 
    .ShrinkToFit = False 
    .ReadingOrder = xlContext 
    .MergeCells = False 
End With 
Selection.Merge 
ActiveCell.Offset(0, 1).Range("A1:A8").Select 
With Selection 
    .HorizontalAlignment = xlCenter 
    .VerticalAlignment = xlTop 
    .WrapText = True 
    .Orientation = 0 
    .AddIndent = False 
    .IndentLevel = 0 
    .ShrinkToFit = False 
    .ReadingOrder = xlContext 
    .MergeCells = False 
End With 
Selection.Merge 
ActiveCell.Offset(0, 1).Range("A1:A8").Select 
With Selection 
    .HorizontalAlignment = xlCenter 
    .VerticalAlignment = xlTop 
    .WrapText = True 
    .Orientation = 0 
    .AddIndent = False 
    .IndentLevel = 0 
    .ShrinkToFit = False 
    .ReadingOrder = xlContext 
    .MergeCells = False 
End With 
Selection.Merge 
ActiveCell.Offset(0, 1).Range("A1:A8").Select 
With Selection 
    .HorizontalAlignment = xlCenter 
    .VerticalAlignment = xlTop 
    .WrapText = True 
    .Orientation = 0 
    .AddIndent = False 
    .IndentLevel = 0 
    .ShrinkToFit = False 
    .ReadingOrder = xlLTR 
    .MergeCells = False 
End With 
Selection.Merge 
ActiveCell.Offset(0, 1).Range("A1:A8").Select 
With Selection 
    .HorizontalAlignment = xlCenter 
    .VerticalAlignment = xlTop 
    .WrapText = True 
    .Orientation = 0 
    .AddIndent = False 
    .IndentLevel = 0 
    .ShrinkToFit = False 
    .ReadingOrder = xlContext 
    .MergeCells = False 
End With 
Selection.Merge 
ActiveCell.Offset(0, 1).Range("A1:A8").Select 
With Selection 
    .HorizontalAlignment = xlCenter 
    .VerticalAlignment = xlTop 
    .WrapText = True 
    .Orientation = 0 
    .AddIndent = False 
    .IndentLevel = 0 
    .ShrinkToFit = False 
    .ReadingOrder = xlContext 
    .MergeCells = False 
End With 
Selection.Merge 
ActiveCell.Offset(0, 1).Range("A1:A8").Select 
With Selection 
    .HorizontalAlignment = xlCenter 
    .VerticalAlignment = xlTop 
    .WrapText = True 
    .Orientation = 0 
    .AddIndent = False 
    .IndentLevel = 0 
    .ShrinkToFit = False 
    .ReadingOrder = xlContext 
    .MergeCells = False 
End With 
Selection.Merge 
End Sub 

Answer 1

J:Rowエンドのための8行を与えます容易に読むことができるgh。これは、私があなたがしようとしていることを理解するためにもう少し情報が必要なので、あなたの元の質問に答えるものではありません。しかし、これは自分自身と他の人がコードを読みやすくするのに役立ちます。

私は、あなたが選択した行のA列からI列までのすべての列を下に挿入された7行とマージするようにしたい場合、あなたが探していたものを推測し、

Sub splitrowsandmerge() 
' 
' splitrowsandmerge Macro 
' add 7 rows and merge 8 rows for first 9 columns 
' 
' Keyboard Shortcut: Ctrl+Shift+E 
' 

Dim RowArray() As Integer 

check = 0 

For Each cell In Selection 
    If firstTime <> 1 Then 
     ReDim RowArray(0) As Integer 
     RowArray(0) = cell.Row 
     firstTime = 1 
    Else 

     For i = LBound(RowArray) To UBound(RowArray) 
      If RowArray(i) = cell.Row Then 
       check = 1 
       Exit For 
      End If 
     Next i 

     If check <> 1 Then 
      addOne = addOne + 1 
      ReDim Preserve RowArray(addOne) As Integer 
      RowArray(addOne) = cell.Row 
     End If 

     check = 0 
    End If 
Next cell 

RowArray = BubbleSrt(RowArray, False) 
For i = LBound(RowArray) To UBound(RowArray) 

    startCell = RowArray(i) 
    Rows(startCell + 1).EntireRow.Resize(7).Insert 

    With Range(Cells(startCell, 1), Cells(startCell + 7, 9)) 
     .HorizontalAlignment = xlCenter 
     .VerticalAlignment = xlTop 
     .WrapText = True 
     .Orientation = 0 
     .AddIndent = False 
     .IndentLevel = 0 
     .ShrinkToFit = False 
     .ReadingOrder = xlContext 
     .MergeCells = False 
    End With 

    For j = 1 To 9 
     Range(Cells(startCell, j), Cells(startCell + 7, j)).Merge 
    Next j 
Next i 

End Sub 

Public Function BubbleSrt(ArrayIn, Ascending As Boolean) 

Dim SrtTemp As Variant 
Dim i As Long 
Dim j As Long 


If Ascending = True Then 
    For i = LBound(ArrayIn) To UBound(ArrayIn) 
     For j = i + 1 To UBound(ArrayIn) 
      If ArrayIn(i) > ArrayIn(j) Then 
       SrtTemp = ArrayIn(j) 
       ArrayIn(j) = ArrayIn(i) 
       ArrayIn(i) = SrtTemp 
      End If 
     Next j 
    Next i 
Else 
    For i = LBound(ArrayIn) To UBound(ArrayIn) 
     For j = i + 1 To UBound(ArrayIn) 
      If ArrayIn(i) < ArrayIn(j) Then 
       SrtTemp = ArrayIn(j) 
       ArrayIn(j) = ArrayIn(i) 
       ArrayIn(i) = SrtTemp 
      End If 
     Next j 
    Next i 
End If 

BubbleSrt = ArrayIn 

End Function