Question

我写了两个类似的宏，为了提高效率，我想将它们合并为一个。第一个宏在特定行下面的另一个选项卡上添加4个空行，其中列C匹配特定条件。第二个宏将现有选项卡中的4行数据复制到新选项卡，并将该数据粘贴到4个新创建的空白行中。任何帮助将不胜感激！谢谢

附上概念截图：屏幕截图1：Initial State 屏幕截图2：MACRO 1 inserts 4 rows if criteria in column C is met (in this case value = "Part A" 屏幕截图3：MACRO 2 pulls in row data from another sheet and pastes it into the new blank rows on this sheet

FIRST MACRO：

Sub RowAdder_01()

Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Dim PN_01 As Range
Set PN_01 = Range("M17")

    Col = "C"
    StartRow = 1
    BlankRows = 1

        LastRow = Cells(Rows.Count, Col).End(xlUp).Row

        Application.ScreenUpdating = False

        With Worksheets("NEW SHEET")
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) = PN_01 Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
End If
Next R
End With
Application.ScreenUpdating = True

End Sub

第二个宏：

Sub PasteRowData_01()

Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Dim PN_01 As Range
Set PN_01 = Range("M17")

    Col = "C"
    Drop = "A"
    StartRow = 1
    BlankRows = 1

        LastRow = Cells(Rows.Count, Col).End(xlUp).Row

        Application.ScreenUpdating = False

Sheets("OLD SHEET").Rows("54:57").SpecialCells(xlCellTypeVisible).Select
Selection.Copy

    With Worksheets("NEW SHEET")
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) = PN_01 Then
   Sheets(NEW SHEET).Select
    .Cells(R + 1, Drop).Select
    Selection.PasteSpecial

End If
Next R
End With
Application.ScreenUpdating = True

End Sub

Answer 1

请尝试此代码。

Option Explicit

Sub AddAndPaste()

    Dim Ws As Worksheet
    Dim Arr As Variant
    Dim PN_01 As Variant
    Dim Last As Long                        ' column or row
    Dim R As Long

    ' copy from source
    Set Ws = Worksheets("Old Sheet")
    With Ws
        With .UsedRange
            Last = .Columns.Count + .Column - 1
        End With
        Arr = Range(.Cells(54, 1), .Cells(57, Last)).SpecialCells(xlCellTypeVisible).Value
    End With

    Application.ScreenUpdating = False
    ' paste to destination
    Set Ws = Worksheets("New Sheet")
    With Ws
        PN_01 = .Cells(7, "M").Value
        Last = .Cells(.Rows.Count, "C").End(xlUp).Row
        For R = Last To 1 Step -1
            If .Cells(R, "C").Value = PN_01 Then
                With .Cells(R, "A")
                    .Resize(4, 1).EntireRow.Insert Shift:=xlDown
                    .Offset(-4).Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
                End With
                Exit For           ' don't exit if you need to continue looping
            End If
        Next R
    End With
    Application.ScreenUpdating = True
End Sub

Answer 2

您的问题是由插入一行引起的。我们建议使用数组。

bootstrap 4

将两个宏合并为一个

2 个答案: