• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Cellen kleuren indien ze een waarde bevatten in een kolom met vba

Status
Niet open voor verdere reacties.
bascas

bascas

Gebruiker
Lid geworden
18 mei 2006
Berichten
441
Beste helpers,

Flink gezocht maar niet het antwoord gevonden voor mijn vraag.

Ik ben op zoek naar een stukje VBA voor het volgende:

Als in een tabblad kolom A vanaf regel 2 een cel tekst bevat dan moet die cel een kleur krijgen.

Hoe gaat dat?

Groeten Bas
 
Wil je bij voorbaat alle gevulde cellen kleuren of moet het een kleur krijgen nadat je iets hebt ingevuld?
 
SjonR,
Er zijn 3 kolommen als in A tekst staat dan rood, in B groen en in C blauw
 
plaats even een voorbeeldbestand, want anders wordt het gokken.
 
zoiets?

Code: 
Sub bascas()
For Each cl In Sheets("Blad1").Range("A2:C100")
    If cl.Value <> "" Then
        Select Case cl.Column
            Case 1
                 cl.Interior.Color = 255
            Case 2
                cl.Interior.Color = 5296274
            Case 3
                cl.Interior.Color = 15773696
        End Select
    End If
Next
        
End Sub
 
Kan gewoon met voorwaardelijke opmaak
 

Bijlagen

  • Voorbeeld kleuren(J).xlsx
    12,4 KB · Weergaven: 139
Dat klopt Jack, maar TS vraagt expliciet om VBA
 
SjonR, bedankt voor je code, in werkelijkheid staan de teksten in kolom D, E en F. Nu heb ik de range aangepast in jou code maar nu doet hij het niet.

Code: 
Sub bascas()
For Each cl In Sheets("NPS").Range("D2:F200")
    If cl.Value <> "" Then
        Select Case cl.Column
            Case 1
                 cl.Interior.Color = 255
            Case 2
                cl.Interior.Color = 5296274
            Case 3
                cl.Interior.Color = 15773696
        End Select
    End If
Next
        
End Sub
 
Het kolomnummer moet wel overeenstemmen:
Code: 
Sub bascas()
For Each cl In Sheets("NPS").Range("D2:F200")
If cl.Value <> "" Then
Select Case cl.Column
Case 4
cl.Interior.Color = 255
Case 5
cl.Interior.Color = 5296274
Case 6
cl.Interior.Color = 15773696
End Select
End If
Next

End Sub
 
Misschien moet ik een nieuwe vraag stellen. Maar probeer het toch even zo. Naast die 3 kolommen staat nog een kolom met tekst. Nu zou ik graag die 4 kolommen willen kopiëren naar een ander tabblad waarbij kolom A, B en C recht onder elkaar worden gezet met kolom D ernaast.
Ik heb het voorbeeld bestand even aangepast.

Bekijk bijlage Voorbeeld kleuren.xlsx
 
?

Code: 
Sub bascas()
Sheets("Blad1").Range("A2:D100").Copy Sheets("zo moet het worden").Cells(1, 1)
Sheets("zo moet het worden").Cells(1, 1).SpecialCells(4).Delete xlShiftToLeft

End Sub
 
Top SjonR,

Kan het ook nog met behoud van kolombreedte erin?
 
zo dan?
Code: 
Sub bascas()

With Sheets("zo moet het worden")
    Sheets("Blad1").Range("A2:D100").Copy .Cells(1, 1)
    .Cells(1, 1).SpecialCells(4).Delete xlShiftToLeft
    .Range("A:A").ColumnWidth = 55
    .Rows.AutoFit
End With
End Sub
 
Laatst bewerkt:
Precies wat ik bedoel! Stel dat ik nog tekst vanuit een ander blad er recht onder wil plakken, welke code zou dat moeten worden dan. het is belangrijk om het te laten aansluiten, aangezien ik het daarna wil sorteren.
 
Laatst bewerkt:
Ongeveer dezelfde code, enkel de invoegregel opzoeken.
Code: 
Sub bascas()
With Sheets("zo moet het worden")
 Sheets("Ander Blad").Range("A2:D100").Copy .Cells(.Range("A" & .Rows.Count).End(xlUp).Row + 1, 1)
   .Cells(1, 1).SpecialCells(4).Delete xlShiftToLeft
   .Columns(1).ColumnWidth = 125
   .Cells.EntireRow.AutoFit
End With
End Sub

Wel Ander Blad naamgeving aanpassen.
 
Kleur en copy in 1 keer

Code: 
Sub bascas()
ar = Array(255, 5296274, 15773696)
  For j = 1 To 3
    With Blad1.Range("A2:C100").Columns(j).SpecialCells(2)
         .Interior.Color = ar(j - 1)
         .Copy Blad2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
         .Offset(, 4 - j).Copy Blad2.Cells(Rows.Count, 2).End(xlUp).Offset(1)
    End With
  Next j
 
  Blad2.Columns(1).ColumnWidth = 80
  Blad2.Cells.EntireRow.AutoFit
End Sub
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan