How to clear cells if criteria met after copying to new worksheet?

Question

I want to clear the value in D34:155 if criteria value "Fælles" or "Lagt ud" is in the cell and the text is NOT bold.

I do not have much coding experience yet. I have tried some clear ranges and delete which didn't work. With this last code it just seems like it clears random places in the range.

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

It is the very last part of the code i need help with. Where it says "Clear" Help is much appreciated. Thank you for taking the time to read through!

Answer 1

You can avoid unexpected behaviour, have less typing and make your code more readable) by using an WITH..END WITH block. For example like this ;

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