Selecteren wanneer aan meerdere voorwaarden wordt voldaan.

[Jelle2010]

Beste Experts,

Ik heb de onderstaande code gemaakt(zie ook bijlage). De IF voorwaarde wil ik graag iets uitgebreider zien maar ik weet niet hoe. Graag wil ik hier nog aan toegevoegd hebben dat als(IF) er in kolom D van die rij "AS" voorkomt.

Alvast vriendelijk bedankt voor jullie hulp.

Sub KleurKopiëren()

Dim LastRow As Long
Dim X As Long
Dim r As Range
Dim CopyRow As Integer

ActiveSheet.Unprotect

Application.ScreenUpdating = False

LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row

For Each r In Range("IV1:IV" & LastRow)
If r.Interior.ColorIndex = 4 And r.Value = Empty Then
r.EntireRow.Copy
X = X + 1
Sheets("Blad2").Range("A" & X).PasteSpecial
r.EntireRow.Interior.ColorIndex = 7
r.Value = Date
r.EntireRow.Locked = True
End If
Next

Application.ScreenUpdating = True

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True, AllowFormattingCells:=True

End Sub

 

[Jelle2010]

Probleem alsnog opgelost. Zie de code hieronder.

Sub KleurKopiëren()

Dim LastRow As Long
Dim X As Long
Dim r As Range
Dim rijnummer As Integer
Dim CopyRow As Integer

ActiveSheet.Unprotect

Application.ScreenUpdating = False

LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row

For Each r In Range("IV1:IV" & LastRow)
rijnummer = r.Row
If r.Interior.ColorIndex = 4 And r.Value = Empty And Range("D" & rijnummer).Value = "D" Then
r.EntireRow.Copy
X = X + 1
Sheets("Blad2").Range("A" & X).PasteSpecial
r.EntireRow.Interior.ColorIndex = 7
r.Value = Date
r.EntireRow.Locked = True
End If
Next

Application.ScreenUpdating = True

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True, AllowFormattingCells:=True

End Sub

Beste Experts,

Ik heb de onderstaande code gemaakt(zie ook bijlage). De IF voorwaarde wil ik graag iets uitgebreider zien maar ik weet niet hoe. Graag wil ik hier nog aan toegevoegd hebben dat als(IF) er in kolom D van die rij "AS" voorkomt.

Alvast vriendelijk bedankt voor jullie hulp.

Sub KleurKopiëren()

Dim LastRow As Long
Dim X As Long
Dim r As Range
Dim CopyRow As Integer

ActiveSheet.Unprotect

Application.ScreenUpdating = False

LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row

For Each r In Range("IV1:IV" & LastRow)
If r.Interior.ColorIndex = 4 And r.Value = Empty Then
r.EntireRow.Copy
X = X + 1
Sheets("Blad2").Range("A" & X).PasteSpecial
r.EntireRow.Interior.ColorIndex = 7
r.Value = Date
r.EntireRow.Locked = True
End If
Next

Application.ScreenUpdating = True

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True, AllowFormattingCells:=True

End Sub

 

[snb]

of

Sub KleurKopiëren()
  Application.ScreenUpdating = False
  ActiveSheet.Unprotect

  For Each cl In columns(256).specialcells(xlcelltypeblanks)
     If cl.Interior.ColorIndex = 4 And cl.offset(,-251) = "D" Then
        cl.Value = Date
        with cl.entirerow
           .copy Sheets("Blad2").cells(rows.count,1).end(xlup).offset(1)
           .Interior.ColorIndex = 7
           .Locked = True
        end with
     End If
  Next

  ActiveSheet.Protect 
  Application.ScreenUpdating = True
End Sub