Opgelost Code verkorten/verbeteren

Dit topic is als opgelost gemarkeerd
Status
Niet open voor verdere reacties.
G

goose323

Gebruiker
Lid geworden
23 apr 2024
Berichten
21
Ik heb onderstaande code gemaakt om formules te plaatsen in een cel en een 2e formule in een andere cel met een voorwaarde. tevens wil ik dan van een aantal omliggende cellen de opmaak (kleur) aanpassen. Ik ben aan onderstaande code gekomen (deze werkt), maar nu vraag ik mij af, of het ook korter en/of overzichtelijker kan (voornamelijk de cel opmaak)



Sub kolom_formule_kleur()


'Opmaak kolombreedte

Columns("A:A").Select
Selection.ColumnWidth = 27
Columns("B:B").Select
Selection.ColumnWidth = 13
Columns("E:E").Select
Selection.ColumnWidth = 70
Columns("F:F").Select
Selection.ColumnWidth = 12
Columns("H:H").Select
Selection.ColumnWidth = 6
Columns("G:G").Select
Selection.ColumnWidth = 12
Columns("J:J").Select
Selection.ColumnWidth = 26
Columns("K:K").Select
Selection.ColumnWidth = 6
Columns("L:L").Select
Selection.ColumnWidth = 8
Columns("M:M").Select
Selection.ColumnWidth = 12
Columns("N:N").Select
Selection.ColumnWidth = 6
Columns("O:O").Select
Selection.ColumnWidth = 18
Columns("P:P").Select
Selection.ColumnWidth = 35


'Opmaak kolommen N en H naar getal zonder cijfer achter de komma
Columns("N:N").Select
Selection.NumberFormat = "0"
Columns("H:H").Select
Selection.NumberFormat = "0"

'
'
'

'Kolom N aanvullen met een formule
Dim lidrij As Integer
lidrij = 2
Dim mijnobject As Object
Set mijnobject = Range("n" & lidrij)

Range("m:m").Sort Key1:=Range("m2"), Order1:=xlAscending

KolomN:

Range("n" & lidrij).Select

If ActiveCell.Offset(, -1) = "" Then
lidrij = 2
GoTo KolomH

Else
ActiveCell.FormulaR1C1 = "=NOW()-RC[-1]"
lidrij = lidrij + 1
GoTo KolomN

End If

KolomH:
'Kolom H aanvullen met een formule
Range("h" & lidrij).Select

If ActiveCell.Offset(, 2) = "tekst 1" Then
ActiveCell.FormulaR1C1 = "=NOW()-RC[1]"
ActiveCell.Interior.Color = RGB(146, 208, 80)
ActiveCell.Offset(0, 2).Select
ActiveCell.Interior.Color = RGB(146, 208, 80)
ActiveCell.Offset(0, -4).Select
ActiveCell.Interior.Color = RGB(146, 208, 80)
ActiveCell.Offset(0, 1).Select
ActiveCell.Interior.Color = RGB(146, 208, 80)
ActiveCell.Offset(0, 1).Select

lidrij = lidrij + 1
GoTo KolomH

ElseIf ActiveCell.Offset(, 2) = "tekst 2" Then
ActiveCell.FormulaR1C1 = "=NOW()-RC[1]"
ActiveCell.Interior.Color = RGB(146, 208, 80)
ActiveCell.Offset(0, 2).Select
ActiveCell.Interior.Color = RGB(146, 208, 80)
ActiveCell.Offset(0, -4).Select
ActiveCell.Interior.Color = RGB(146, 208, 80)
ActiveCell.Offset(0, 1).Select
ActiveCell.Interior.Color = RGB(146, 208, 80)
ActiveCell.Offset(0, 1).Select
lidrij = lidrij + 1
GoTo KolomH

ElseIf ActiveCell.Offset(, 2) = "tekst 3" Then
ActiveCell.FormulaR1C1 = "=NOW()-RC[1]"
ActiveCell.Interior.Color = RGB(255, 192, 0)
ActiveCell.Offset(0, 2).Select
ActiveCell.Interior.Color = RGB(255, 192, 0)
ActiveCell.Offset(0, -4).Select
ActiveCell.Interior.Color = RGB(255, 192, 0)
ActiveCell.Offset(0, 1).Select
ActiveCell.Interior.Color = RGB(255, 192, 0)
ActiveCell.Offset(0, 1).Select
lidrij = lidrij + 1
GoTo KolomH

ElseIf ActiveCell.Offset(, 2) = "" Then
Exit Sub

End If

lidrij = lidrij + 1
GoTo KolomH


End Sub
 
als ik het zo lees is de opmaak en de formule van "tekst 1" en "tekst 2" hetzelfde, klopt dit?
 
Het kan vast beter maar ik heb er dit van gemaakt.

Code: 
Sub kolom_formule_kleur()

Dim lidrij As Integer
lidrij = 2

Columns("A:A").ColumnWidth = 27
Columns("B:B").ColumnWidth = 13
Columns("E:E").ColumnWidth = 70
Columns("F:F").ColumnWidth = 12
Columns("H:H").ColumnWidth = 6
Columns("G:G").ColumnWidth = 12
Columns("J:J").ColumnWidth = 26
Columns("K:K").ColumnWidth = 6
Columns("L:L").ColumnWidth = 8
Columns("M:M").ColumnWidth = 12
Columns("N:N").ColumnWidth = 6
Columns("O:O").ColumnWidth = 18
Columns("P:P").ColumnWidth = 35

'Opmaak kolommen N en H naar getal zonder cijfer achter de komma
Columns("N:N").NumberFormat = "0"
Columns("H:H").NumberFormat = "0"

'Kolom N aanvullen met een formule
Range("m:m").Sort Key1:=Range("m2"), Order1:=xlAscending

LastRow = Range("M65536").End(xlUp)

    For lidrij = 2 To LastRow Step 1
         Cells(lidrij, 14).Formula = "=NOW()-RC[-1]"
            If Cells(lidrij, 10) = "tekst 1" Then
                Cells(lidrij, 8).Formula = "=NOW()-RC[1]"
                Cells(lidrij, 8).Interior.Color = RGB(146, 208, 80)
                Cells(lidrij, 10).Interior.Color = RGB(146, 208, 80)
                Cells(lidrij, 4).Interior.Color = RGB(146, 208, 80)
                Cells(lidrij, 9).Interior.Color = RGB(146, 208, 80)
                
                    ElseIf Cells(lidrij, 10) = "tekst 2" Then
                        Cells(lidrij, 8).Formula = "=NOW()-RC[1]"
                        Cells(lidrij, 8).Interior.Color = RGB(146, 208, 80)
                        Cells(lidrij, 10).Interior.Color = RGB(146, 208, 80)
                        Cells(lidrij, 4).Interior.Color = RGB(146, 208, 80)
                        Cells(lidrij, 9).Interior.Color = RGB(146, 208, 80)
                    
                        ElseIf Cells(lidrij, 10) = "tekst 3" Then
                            Cells(lidrij, 8).Formula = "=NOW()-RC[1]"
                            Cells(lidrij, 8).Interior.Color = RGB(255, 192, 0)
                            Cells(lidrij, 10).Interior.Color = RGB(255, 192, 0)
                            Cells(lidrij, 4).Interior.Color = RGB(255, 192, 0)
                            Cells(lidrij, 9).Interior.Color = RGB(255, 192, 0)
           End If
    Next
    

End Sub
 
Kun je de kolombreedtes niet makkelijker aanpassen met
Code: 
Cells.EntireColumn.AutoFit
en de celkleur via voorwaardelijke opmaak?
 
ietsje korter kan ook.
Code: 
columns.autofit
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan