VBA code geeft storing

[Roma]

Beste specialisten.

Ik heb 2 VBA codes

1:

Private Sub Commandbutton1_Click()
blad = ActiveSheet.Name
Application.ScreenUpdating = False
      Worksheets("NLC Fase 1").Range("B16:R16").Copy Destination:=Worksheets("1").Range("B16:R16")
      Worksheets("NLC Fase 1").Range("C18:R18").Copy Destination:=Worksheets("1").Range("C18:R18")
 
    Application.ScreenUpdating = True
  End Sub

2:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal target As Range)
If WorksheetFunction.Or(Sh.Name = "NLC Fase 1", Sh.Name = "NLC Fase 2", Sh.Name = "NLC Fase 3", Sh.Name = "1") Then
If Not Intersect(target, Range("B16:R16, C18:R18, C20:N20, B24:R24,C26:R26, C28:N28, B32:R32, C34:R34, C36:N36, B40:R40, C42:R42,C44:N44, B48:R48, C50:R50,C52:N52")) Is Nothing Then
    With Sheets("Activiteiten").Range("B4:H27")
        Set c = .Find(target.Value, LookIn:=xlValues, LookAt:=xlWhole)
       Sh.Unprotect ""
        If Not c Is Nothing Then
            target.Interior.Color = c.Interior.Color
'            Target.Offset(44).Interior.Color = c.Interior.Color
'            Target.Offset(87).Interior.Color = c.Interior.Color
        Else
            target.Interior.Color = xlNone
           MsgBox "Je hebt een ongeldige code gekozen." & vbNewLine & "Kies een andere code.", vbExclamation, "Kleurencode."
            target.Value = ""
        End If
       Sh.Protect ""
    End With
    End If
  End If
End Sub

Als ik code 1 laat draaien dan krijg ik een foutmelding bij code:2

If Not Intersect(target, Range("B16:R16, C18:R18, C20:N20, B24:R24,C26:R26, C28:N28, B32:R32, C34:R34, C36:N36, B40:R40, C42:R42,C44:N44, B48:R48, C50:R50,C52:N52")) Is Nothing Then

foutmelding is: foutmelding 1004 tijdens uitvoering
methode Intersect van object_Global is mislukt

Kan iemand bij helpen om deze fout op te lossen

 

[jkpieterse]

Verander:

If Not Intersect(target, Range("B16:R16, ...........

in

If Not Intersect(target, [COLOR="#FF0000"]Sh.[/COLOR]Range("B16:R16, ...........

 

[Roma]

Bedankt maar..........
DE te kopiëren cellen zijn gedeeltelijk met een kleur.
Als ik nu ga kopiëren dan worden alle cellen dezelfde kleur en dat is niet de bedoeling
Wat kan ik hier aan doen

 

[jkpieterse]

Ik heb je aangegeven hoe de foutmelding voorkomen kan worden. Wat is precies de bedoeling van je code? Heb je een voorbeeld bestandje voor ons om mee te experimenteren?

 

[Roma]

Hierbij een voorbeeld

 

[jkpieterse]

En de bedoeling is? Als je antwoorden wilt, zal je vragen moeten stellen en informatie moeten geven. Maak het ons makkelijk om je te helpen!

 

[Roma]

Wat is de bedoeling,
Dat de juiste kleuren en nrs van het ene tabblad naar het andere tabblad gekopieerd worden.
In dit voorbeeld is maar 1 rij dat gekopieerd wordt maar in het echte bestand zijn er meerdere.
Als de kleuren niet mee gekopieerd kunnen worden dan zijn de nrs alleen ook voldoende.

 

[jkpieterse]

Ik verwacht dat dit doet wat jij zoekt (Target kan meer dan 1 cel zijn...)

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal target As Range)
    Dim oCell As Range
    Dim oFoundCell As Range
    If WorksheetFunction.Or(Sh.Name = "NLC Fase 1", Sh.Name = "1") Then
        If Not Intersect(target, Sh.Range("B16:R16, C18:R18, C20:N20  ")) Is Nothing Then
            With Sheets("Activiteiten").Range("B4:H27")
                For Each oCell In target.Cells
                    Set oFoundCell = .Find(oCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
                    Sh.Unprotect ""
                    If Not oFoundCell Is Nothing Then
                        oCell.Interior.Color = oFoundCell.Interior.Color
                    Else
                        oCell.Interior.Color = xlNone
                        MsgBox "Je hebt een ongeldige code gekozen." & vbNewLine & "Kies een andere code.", vbExclamation, "Kleurencode."
                        oCell.Value = ""
                    End If
                Next
            End With
        End If
    End If
End Sub

 

[Roma]

Beste Jan Karel
Het werkt perfect. Precies de bedoeling van het geheel.:thumb:
Bedankt.