修改VBA代码：将指定行插入数据顶部而非底部首个空行

原代码功能：在当前工作表中查找A列标记为"x"的行，将该行（从B列开始的86列数据）复制到指定工作簿的Orders Confirmed工作表的最后一行空行，同时将该行G列标红，最后清理指定区域并提示完成。

需求调整：将复制的行粘贴到目标工作表的表头下方第一行（固定第6行上方），而非末尾空行。

修改后的完整代码 #

Sub addtoconfirmdatabase()
    
    Const WB_PATH As String = "S:\Goods Ordering\Confirmed Orders.xlsx"
    Dim srcSht As Worksheet, wb As Workbook, shtDest As Worksheet, i As Long
    
    Set srcSht = ActiveSheet
    
    For i = 2 To srcSht.Range("A" & srcSht.Rows.Count).End(xlUp).Row
        If srcSht.Cells(i, 1) = "x" Then
            
            If shtDest Is Nothing Then
                Set wb = Workbooks.Open(Filename:=WB_PATH)
                Set shtDest = wb.Sheets("Orders Confirmed")
            End If
            
            ' 关键修改：在第6行上方插入空行并粘贴数据
            shtDest.Rows(6).Insert Shift:=xlDown
            srcSht.Cells(i, 2).Resize(1, 86).Copy shtDest.Cells(6, 1)
            
            ' 标记当前行G列颜色
            srcSht.Cells(i, 7).Interior.ColorIndex = 46
        End If
        
    Next i
    
    If Not wb Is Nothing Then wb.Close True
    
    Sheets("Quote Database").Select
    Range("P1:R1").ClearContents
    
    MsgBox "已将订单添加至确认订单数据库。"
End Sub

修改说明 #

1. 核心修改点：

   • 替换原代码中粘贴到末尾空行的逻辑，改为先在第6行位置插入空行，再将数据粘贴到新插入的第6行，实现固定在第6行上方添加数据的效果，原有第6行及以下内容自动下移。
   • 合并了重复的If srcSht.Cells(i, 1) = "x"判断，减少冗余代码。

2. 额外优化：

   • 将提示框文本改为中文，适配使用场景。

原代码（供对比） #

Sub addtoconfirmdatabase()
    
    Const WB_PATH As String = "S:\Goods Ordering\Confirmed Orders.xlsx"
    Dim srcSht As Worksheet, wb As Workbook, shtDest As Worksheet, i As Long
    
    Set srcSht = ActiveSheet
    
    For i = 2 To srcSht.Range("A" & srcSht.Rows.Count).End(xlUp).Row
        If srcSht.Cells(i, 1) = "x" Then
            
            If shtDest Is Nothing Then
                Set wb = Workbooks.Open(Filename:=WB_PATH)
                Set shtDest = wb.Sheets("Orders Confirmed")
            End If
            srcSht.Cells(i, 2).Resize(1, 86).Copy _
        shtDest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        End If
        If srcSht.Cells(i, 1) = "x" Then
            srcSht.Cells(i, 7).Interior.ColorIndex = 46
        End If
        
    Next i
    
    
    If Not wb Is Nothing Then wb.Close True
    
    Sheets("Quote Database").Select
    Range("P1:R1").ClearContents
    
    MsgBox "your orders have been added to the orders confirmed database."
    
End Sub

内容的提问来源于stack exchange，提问作者Charlotte