Excel VBA宏从一个单元格到多个单元格

Question

如果您一次套用至一个储存格（或如果您拖曳多列，将在最左上角储存格的行上使用），这个巨集就会运作。 有没有一种方法可以进一步调整它，使我的宏将更改应用于所有选定单元格的行，以便用户可以批量更改行？

我记录了一个宏，该宏将最后一行的第一行中的行分成8行columns J:Q我的逻辑是在选定单元格上方插入7行（该行位于将要合并的单元格下方），然后与columns A:I的原始现有行

这将给我A:I一个单元格， J:Row End有8行

*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

我做了一些调整，以使这些代码更有意义，并使通俗易懂。 这无法回答您的原始问题，因为我需要更多信息来了解您的尝试。 但这应该可以帮助我自己和其他人更轻松地阅读您的代码。

如果您希望将选择的行中从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