Meerdere cellen met automatische opmaak kopiëren

Status
Niet open voor verdere reacties.

bomseler

Gebruiker
Lid geworden
31 aug 2016
Berichten
53
Beste forumleden,


Ik heb een blad gemaakt waarin automatisch velden worden opgemaakt als je een naam intypt. De opmaak hiervan is hetzelfde als in een lijst op een ander blad. Dit werkt op zichzelf prima.

Als ik 1 cel (E9) met een naam (Henk in dit voorbeeld) kopieer en plak (in cel G9) dan worden de 3 cellen op de juiste manier opgemaakt.

Als ik echter meerdere cellen (bijvoorbeeld E9:E11 of, zoals in het voorbeeld D9:E11) wil kopiëren dan krijg ik een foutmelding.


Iemand een idee hoe ik dit kan ondervangen in de code? Of moet ik dan een aparte macro maken voor het 'kopiëren/plakken" van meerdere cellen?
Alvast hartelijk dank!

Bekijk bijlage Voorbeeld_VW-opmaak.xlsm
 
Laatst bewerkt:
En weer zegt er iemand een foutmelding te krijgen zonder erbij te vertellen welke van de duizenden mogelijke meldingen dat dan is :rolleyes:
 
Het moet natuurlijk wel een beetje spannend blijven :)
 
Excuses,

Bijlage heb ik aan het eerste bericht toegevoegd.

Foutmelding is:
'Fout 13, typen komen niet met elkaar overeen.'
 
Split de coderegel.

Code:
If Cells(Target.Row, 2) = "test1" Then
If Target.Value = naam Then
en zet onderaan de code nog een 'end if' bij.
 
HSV,

Ik krijg nog steeds dezelfde foutmelding (fout 13) op de regel in het rood.



Code:
Private Sub Worksheet_Change(ByVal Target As Range)

Dim naam As String
Dim i As Long
On Error GoTo lege_cel

If Target.Value <> "" Then
naam = Target.Value
    Select Case Target.Value
        Case naam
            i = Application.Match(naam, Sheets("namen").Range("E3:E58"), 0)
            
            clr_int = Sheets("namen").Cells(i + 2, 2).Value
            clr_fon = Sheets("namen").Cells(i + 2, 3).Value
        Case Else
    End Select

lege_cel:
Else
        clr_int = 0
        clr_fon = 1
        With Target.Resize(3, 1)
            .Interior.ColorIndex = clr_int
            .Borders(xlEdgeLeft) = xlLineStyleNone
            .Borders(xlEdgeRight) = xlLineStyleNone
        End With
End If

If Cells(Target.Row, 2) = "test1" Then
[COLOR="#FF0000"]If Target.Value = naam Then[/COLOR]
  
  With Target.Resize(3, 1)
        .Interior.ColorIndex = clr_int
        .Font.ColorIndex = clr_fon
        With Target.Resize(3, 1)
            .Interior.ColorIndex = clr_int
            .BorderAround xlContinuous, xlThin
        End With
    End With
End If
End If

End Sub
 
Code:
naam = target.value
if target.value = naam
if target.value = target.value

laat je gedachten daar eens over gaan.
 
Dat gaat inderdaad niet goed, logisch dat daar een foutmelding van komt. Ik heb dit deel weggehaald.

Ik heb de code wat aangepast alleen ik denk dat ik er met deze code niet uit ga komen.
Target gaat denk ik over 1 cel? Als ik dan 2 cellen tegelijk plak kan 'target' deze dan wel tegelijkertijd/automatisch na elkaar behandelen?

Zou 'target' dan vervangen moeten worden voor een code die het volgende doet? (ik krijg het niet voor elkaar hier een juiste code voor te maken dus vandaar dat ik het in stappen opsom)

1. de waarde van elke cell in de selectie (in de rij waar 'test1' voor staat) vergelijken met de lijst 'namen'
2. als er een overeenkomst is deze opmaken volgens de code die hieronder staat.


Of zeg ik nu hele rare dingen? :rolleyes:


Code:
Private Sub Worksheet_Change(ByVal Target As Range)

Dim clr_int, clr_fon
Dim naam As String
Dim i As Long
On Error GoTo einde

If Target.Value <> "" Then
naam = Target.Value
            i = Application.Match(naam, Sheets("namen").Range("E3:E58"), 0)
                        clr_int = Sheets("namen").Cells(i + 2, 2).Value
                        clr_fon = Sheets("namen").Cells(i + 2, 3).Value

If Cells(Target.Row, 2) = "test1" Then
  With Target.Resize(3, 1)
        .Interior.ColorIndex = clr_int
        .Font.ColorIndex = clr_fon
        With Target.Resize(3, 1)
            .Interior.ColorIndex = clr_int
            .BorderAround xlContinuous, xlThin
        End With
    End With
    GoTo einde
End If

lege_cel:
Else
        clr_int = 0
        clr_fon = 1
        With Target.Resize(3, 1)
            .Interior.ColorIndex = clr_int
            .Borders(xlEdgeLeft) = xlLineStyleNone
            .Borders(xlEdgeRight) = xlLineStyleNone
        End With
End If

einde:
End Sub
 
ik weet niet wat je wil.
Code:
dim i as variant
'of dim i

i = Application.Match(naam, Sheets("namen").Range("E3:E58"), 0)
if not iserror(i) then blabla
 
De hele code op zichzelf werkt wel, als ik een naam in een rij typ waar 'test1' voor staat worden de 3 vakjes onder elkaar opgemaakt.
Ook als ik alleen de cel met de naam kopieer en ergens anders plak in een rij waar 'test1' voor staat worden de 3 vakjes onder elkaar opgemaakt.

Het probleem is echter dat als ik meerdere namen naast elkaar (dus een selectie van 2 of meer cellen) kopieer en deze vervolgens ergens plak dat ik dan een foutmelding krijg.

Dus eigenlijk heb ik een 'targetrange' nodig waarbij voor elke cel in de selectie en die in de rij 'test1' staat gecontroleerd moet worden of deze in de lijst namen staat en op basis daarvan opgemaakt wordt.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan