如何避免将含空白单元格的行从Sheet1复制到Sheet2（VBA）

问题描述 #

现有一段VBA代码，可将Sheet1中E列值为「TI002768E2XA E005」的行的指定列（对应原表B-F列相关单元格）复制到Sheet2。但部分待复制行的D、F列存在空白值，这些空白行也会被同步复制，现需修改代码以避免复制此类含空白单元格的行。

原代码如下：

Sub SAPDashboard()

Dim LastRow As Long
Dim myRow As Long
Dim myCopyRow As Long
Dim LastRow1 As Long
      
myCopyRow = 3

LastRow = Sheets("Sheet1").Cells(Rows.Count, "E").End(xlUp).Row

Application.ScreenUpdating = False

For myRow = 1 To LastRow

    If Sheets("Sheet1").Cells(myRow, "E") = "TI002768E2XA E005" Then
        Sheets("Sheet2").Cells(myCopyRow, "B") = Sheets("Sheet1").Cells(myRow, "e")
        Sheets("Sheet2").Cells(myCopyRow, "C") = Sheets("Sheet1").Cells(myRow, "d")
        Sheets("Sheet2").Cells(myCopyRow, "D") = Sheets("Sheet1").Cells(myRow, "F")
        Sheets("Sheet2").Cells(myCopyRow, "E") = Sheets("Sheet1").Cells(myRow, "G")
        Sheets("Sheet2").Cells(myCopyRow, "F") = Sheets("Sheet1").Cells(myRow, "H")

        myCopyRow = myCopyRow + 1
    
    End If
    
Next myRow

LastRow1 = Range("b5000").End(xlUp).Row
LastRow = Range("A5000").End(xlUp).Row
Range("E" & LastRow1 + 1).Formula = "=SUM(E3:E" & LastRow1 & ")"
Range("F" & LastRow1 + 1).Formula = "=SUM(F3:F" & LastRow1 & ")"

Columns("A:AB").HorizontalAlignment = xlCenter
Range("B2:F2").Value = Array("Charge Code", "Name", "Title", "Cost", "Hours")
Worksheets("Sheet2").Range("B2:F2").Font.Bold = True
Range("B2:F2").Interior.ColorIndex = 15
Range("B2:F2").EntireColumn.AutoFit
Range("E:E").Style = "Currency"

         
Set rng = Nothing
      
With Range("B2:F" & Range("B" & Rows.Count).End(xlUp).Row)
  .Borders.ColorIndex = 1
  .Borders.Weight = xlThin
  .BorderAround , xlThick, 1
  .Resize(1).Borders(xlEdgeBottom).Weight = xlThick

End With

End Sub

修改方案 #

核心思路 #

在原有判断E列值的条件中，新增对Sheet1当前行D列、F列非空的校验，只有当这两列都不为空时才执行复制操作。同时修正原代码中未指定工作表的Range引用，避免因活动表切换导致的错误。

修改后的完整代码 #

Sub SAPDashboard()

Dim LastRow As Long
Dim myRow As Long
Dim myCopyRow As Long
Dim LastRow1 As Long
      
myCopyRow = 3

LastRow = Sheets("Sheet1").Cells(Rows.Count, "E").End(xlUp).Row

Application.ScreenUpdating = False

For myRow = 1 To LastRow
    ' 新增D、F列非空判断，仅当E列匹配且D、F列都不为空时才复制
    If Sheets("Sheet1").Cells(myRow, "E") = "TI002768E2XA E005" _
        And Not IsEmpty(Sheets("Sheet1").Cells(myRow, "D")) _
        And Not IsEmpty(Sheets("Sheet1").Cells(myRow, "F")) Then
        
        Sheets("Sheet2").Cells(myCopyRow, "B") = Sheets("Sheet1").Cells(myRow, "E")
        Sheets("Sheet2").Cells(myCopyRow, "C") = Sheets("Sheet1").Cells(myRow, "D")
        Sheets("Sheet2").Cells(myCopyRow, "D") = Sheets("Sheet1").Cells(myRow, "F")
        Sheets("Sheet2").Cells(myCopyRow, "E") = Sheets("Sheet1").Cells(myRow, "G")
        Sheets("Sheet2").Cells(myCopyRow, "F") = Sheets("Sheet1").Cells(myRow, "H")

        myCopyRow = myCopyRow + 1
    
    End If
    
Next myRow

With Sheets("Sheet2")
    LastRow1 = .Range("B5000").End(xlUp).Row
    ' 修正求和公式的引用范围，确保基于Sheet2的数据
    .Range("E" & LastRow1 + 1).Formula = "=SUM(E3:E" & LastRow1 & ")"
    .Range("F" & LastRow1 + 1).Formula = "=SUM(F3:F" & LastRow1 & ")"

    .Columns("A:AB").HorizontalAlignment = xlCenter
    .Range("B2:F2").Value = Array("Charge Code", "Name", "Title", "Cost", "Hours")
    .Range("B2:F2").Font.Bold = True
    .Range("B2:F2").Interior.ColorIndex = 15
    .Range("B2:F2").EntireColumn.AutoFit
    .Range("E:E").Style = "Currency"

    ' 修正边框设置的范围引用
    With .Range("B2:F" & .Range("B" & .Rows.Count).End(xlUp).Row)
      .Borders.ColorIndex = 1
      .Borders.Weight = xlThin
      .BorderAround , xlThick, 1
      .Resize(1).Borders(xlEdgeBottom).Weight = xlThick
    End With
End With

Set rng = Nothing
Application.ScreenUpdating = True

End Sub

关键修改点 #

• 新增非空判断：在If条件中加入And Not IsEmpty(Sheets("Sheet1").Cells(myRow, "D")) And Not IsEmpty(Sheets("Sheet1").Cells(myRow, "F"))，确保只有D、F列都不为空的行才会被复制。
• 指定工作表对象：将所有未明确工作表的Range操作包裹在With Sheets("Sheet2")中，避免因当前活动表不是Sheet2而导致的错误。
• 恢复屏幕更新：在代码末尾添加Application.ScreenUpdating = True，确保执行完代码后恢复Excel的屏幕刷新功能。

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