VBA找空行，然后復制上面兩行，然后移到下一個空行

假設您有以下格式的 Excel 資料

Row A
Row B
Row C 
blank row
Row X
Row Y
Row Z
blank

我想 1) 轉到空白行 2) 復制上面兩行的全部內容 3) 粘貼內容。

在上面的例子中，結果將是

Row A
Row B
Row C
Row B
Row C
blank
Row X
Row Y
Row Z
Row Y
Row Z
blank

我能夠找到空白。我的代碼目前看起來像

Sub Find_Copy()

Dim rCell As Range
Dim r As Range
Dim r2 As Range

'We call the function and tell it to start the search in cell B1.
Set rCell = FindNextEmpty(Range("B8")) 'this is a separate function

'Shows a message box with the cell address. Right here is where
'you write the code that uses the empty cell.
rCell.Value = "Filled by macro 999"
MsgBox rCell.Address & " " & rCell.Value

    rCell.Offset(-2, 0).EntireRow.Select 'dmt, select the row one above the blanks
    Selection.Copy
    Selection.Insert Shift:=xlDown
    
Set rCell = Nothing

End Sub

誰能幫我解決這個問題？謝謝！

uj5u.com熱心網友回復：

完成作業的 sub 是enhanceList. 它將您想要處理的范圍作為引數。

我的宏的基本思想是在插入單元格時自下而上作業。

Option Explicit


Public Sub test_enhanceList()
Dim rg As Range
Set rg = table1.Range("A1:A8")    '<<< adjust to your needs

enhanceList rg

End Sub



' The sub which does the work
Private Sub enhanceList(rgToEnhance As Range)

Dim c As Range
With rgToEnhance
    'we will start at the end of the range
    Set c = .Cells(.Rows.Count)
End With

Dim i As Long

Do
    If LenB(c.Value2) = 0 Then  'test for empty cell
        For i = 1 To 2
            'insert empty cell and take value from 3rd cell above
            c.Insert xlShiftDown
            'c.offset(-1) = new cell
            'c.offset(-3) = value to copy
            c.Offset(-1).Value2 = c.Offset(-3).Value2
        Next
    End If
    Set c = c.Offset(-1) 'set c to the cell above
Loop Until c.Row = rgToEnhance.Cells(1, 1).Row  'stop when first cell is reached

End Sub

uj5u.com熱心網友回復：

在插入后添加它，您可以正確獲得 B 行和 C 行。您必須在函式呼叫之前添加一個具有范圍限制的回圈，以獲取下一個空單元格以添加 Y 和 Z 以及之后可能出現的任何其他內容。發布您的函式代碼，我可能會撰寫一個回圈，稍后再執行。

rCell.Offset(-1, 0).EntireRow.Select 'dmt, select the row one above the blanks
Selection.Copy

rCell.Offset(-2, 0).EntireRow.Select 'dmt, select the row one above the blanks
Selection.Insert Shift:=xlDown

要通過單擊來選擇要執行此操作的列，請更改此行：

Set rCell = FindNextEmpty(ActiveCell.Offset(0, 0))

對此：

Set rCell = FindNextEmpty(Selection)

然后在運行宏之前，選擇單元格 B1

uj5u.com熱心網友回復：

我沒有改變我的答案，而是添加了一個新答案。添加了幾行來查找資料的范圍，然后遍歷范圍內的每個單元格，測驗是否為空。它消除了對額外功能的需要。

嘗試這個：

Sub Dan_Find_Copy()

Dim wkb As Workbook
Dim rCell As Range
Dim r As Range
Dim r2 As Range
Dim colNumber As Integer 'to store the column index
Dim rowNumber As Long    'to store the last row containing data
Dim i As Long 'iterator


'Need to get the range of the data
Set wkb = ActiveWorkbook
'store the column number of the selection
colNumber = Columns(Selection.Column).Column
'find the last row containing data
rowNumber = Cells(Rows.Count, colNumber).End(xlUp).Row
Set r = wkb.ActiveSheet.Range(Sheet1.Cells(1, colNumber), Sheet1.Cells(rowNumber, colNumber))

For Each rCell In r.Cells
    If rCell.Value = "" Then
        If MsgBox("Continue?", vbOKCancel, "Hello!") = vbOK Then

            'Shows a message box with the cell address. Right here is where
            'you write the code that uses the empty cell.
            rCell.Value = "Filled by macro 999"
            MsgBox rCell.Address & " " & rCell.Value
        
            rCell.Offset(-2, 0).EntireRow.Select 'dmt, select the row one above the blanks
            Selection.Copy
            Selection.Insert Shift:=xlDown
        
            rCell.Offset(-1, 0).EntireRow.Select 'dmt, select the row one above the blanks
            Selection.Copy
        
            rCell.Offset(-2, 0).EntireRow.Select 'dmt, select the row one above the blanks
            Selection.Insert Shift:=xlDown
        
            rCell.Select
            
        Else

            MsgBox ("You cancelled the process.")
            Exit For
            
        End If
        
    End If
    
Next rCell
    

Set rCell = Nothing
Set r = Nothing
Set wkb = Nothing

End Sub

標籤：擅长 vba 抵消 空行

上一篇：Excel格式代碼

下一篇：在excel中用VBA過濾