Question

如果您一次应用于一个单元格（或者如果您拖动多行，则将在最左上角的单元格的行上工作），此宏将起作用。有没有办法我可以进一步调整它以使我的宏将更改应用于所有选定单元格的行，以便用户可以批量更改行？

我录制了一个宏，它会将作为一行存在的内容拆分为最后一行columns J:Q的8行我的逻辑是在所选单元格上方插入7行（存在于将要合并的单元格下方），然后将这些行与columns A:I的原始现有行合并

这将为A:I提供一个单元格，为J:Row结束

提供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

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

1 个答案: