Question

如果标准值“Fælles”或“ Lagt ud”位于单元格中且文本不是粗体，我想清除D34：155中的值。

我还没有太多的编码经验。我尝试了一些清除范围并删除了无效的内容。有了最后的代码，似乎就清除了范围内的随机位置。

Private Sub CommandButton1_Click()

A = Worksheets("Stig Okt").Cells(Rows.Count, 1).End(xlUp).Row

For i = 34 To A
If Worksheets("Stig Okt").Cells(i, 4).Font.Bold = False And Cells(i, 4).Value = "Fælles" Then
    Worksheets("Stig Okt").Rows(i).Columns("A:H").Copy
    Worksheets("Laura Okt").Activate
    b = Worksheets("Laura Okt").Cells(Rows.Count, 1).End(xlUp).Row
    Worksheets("Laura Okt").Cells(b + 1, 1).Select
    ActiveSheet.Paste
End If

If Worksheets("Stig Okt").Cells(i, 4).Font.Bold = False And Cells(i, 4).Value = "Lagt ud" Then
    Worksheets("Stig Okt").Rows(i).Columns("A:H").Copy
    Worksheets("Laura Okt").Activate
    b = Worksheets("Laura Okt").Cells(Rows.Count, 1).End(xlUp).Row
    Worksheets("Laura Okt").Cells(b + 1, 1).Select
    ActiveSheet.Paste
End If

If Worksheets("Laura Okt").Cells(i, 4).Value = "Fælles" And Cells(i, 4).Font.Bold = False Then
    Worksheets("Laura Okt").Cells(i, 4).Clear
ElseIf Worksheets("Laura Okt").Cells(i, 4).Value = "Lagt ud" And Cells(i, 4).Font.Bold = False Then
    Worksheets("Laura Okt").Cells(i, 4).Clear
End If
Next
Worksheets("Stig Okt").Activate


End Sub

这是我需要帮助的代码的最后一部分。上面写着“清除” 非常感谢您的帮助。感谢您抽出宝贵的时间来阅读！

Answer 1

由于在上面的代码中四次无条件引用Cells属性时，您可能会看到随机行为。我相信，当Cells属性引用不合格时，默认行为是在执行代码时使用活动电子表格的Cells属性。

例如上面的代码显示：

If Worksheets("Stig Okt").Cells(i, 4).Font.Bold = False And Cells(i, 4).Value = "Lagt ud" Then

但是您实际上可能打算这样做：

If Worksheets("Stig Okt").Cells(i, 4).Font.Bold = False And Worksheets("Stig Okt").Cells(i, 4).Value = "Lagt ud" Then

希望这会有所帮助！

Answer 2

通过使用WITH..END WITH块，可以避免意外的行为，减少键入并使代码更具可读性。例如这样；

Sub process()

  ' scan down sheet "Stig Jan" from 36 to last row
  '   where col D font is NOT bold AND col D value = "Fælles" Or "Lagt Ud"
  '     copy columns "A:H" to sheet "Laura Jan", appending to existing records
  '     clear col D on "Laura Jan"
  '   where col N font is NOT bold and col N value = "Fælles" Or "Lagt Ud"
  '     copy columns "K:R" to sheet "Laura Jan", appending to existing records
  '     clear col N on "Laura Jane"

  Dim wsSource, wsTarget As Worksheet
  Dim i, iLastSource, iRowTarget, count As Long
  Dim cell As Range

  Set wsSource = Worksheets("Stig Jan")
  iLastSource = wsSource.cells(Rows.count, 1).End(xlUp).Row

  Set wsTarget = Worksheets("Laura Jan")

  count = 0
  With wsSource
    iRowTarget = wsTarget.cells(Rows.count, 1).End(xlUp).Row + 1
    For i = 36 To iLastSource
      ' check col 4 (D) and copy "A:H" to Laura "A:H" last row
      Set cell = .cells(i, 4)
      If cell.Font.Bold = False Then
        If cell.Value = "Fælles" Or cell.Value = "Lagt Ud" Then
          .Rows(i).Columns("A:H").Copy wsTarget.Range("A" & iRowTarget)
          'wsTarget.Range("D" & iRowTarget).ClearContents
          wsTarget.Range("D" & iRowTarget).Interior.Color = vbRed ' replace this line with ClearContent
          iRowTarget = iRowTarget + 1
          count = count + 1
        End If
      End If
    Next

    iRowTarget = wsTarget.cells(Rows.count, 11).End(xlUp).Row + 1
    For i = 36 To iLastSource
      ' check col 14 (N) and copy "K:R" to Laura "K:R" last row
      Set cell = .cells(i, 14)
      If cell.Font.Bold = False Then
        If cell.Value = "Fælles" Or cell.Value = "Lagt Ud" Then
          .Rows(i).Columns("K:R").Copy wsTarget.Range("K" & iRowTarget)
          'wsTarget.Range("N" & iRowTarget).ClearContents
          wsTarget.Range("N" & iRowTarget).Interior.Color = vbRed ' replace this line with ClearContent
          iRowTarget = iRowTarget + 1
          count = count + 1
        End If
      End If
    Next
  End With
  MsgBox "Done : " & count & " rows copied"

  End Sub

复制到新工作表后，如果满足条件，如何清除单元格？

2 个答案: