VBA code inkorten mogelijk?

[samabert]

Hallo,

In het werkblad heb ik volgende formule waarvan de twee eerste =ALS gebruikt worden voor volgende:

=ALS(EN(B$22=0;B$24=2);"A";ALS(EN(B$22=1;B$24=1);"A";ALS(EN(B$22=1;B$24>2);"X";ALS(EN(B$22=0;B$24=2);"Y"))))

De bedoeling is dat ik in een bepaalde kolom kijk hoeveel cellen er nog leeg zijn. Indien bij de laatste input er nog 2 cellen leeg zijn en geen getal 2 ingevuld is worden deze automatisch ingevuld met het getal twee, (2 staat voor een namiddag shift). Het gaat over rij 28, check shift 2.

De code die ik hiervoor gebruik is tot hiertoe opgebouwd tot kolom E.

Deze code werkt, maar ik vroeg mij af of het mogelijk is om deze code korter te schrijven?
Rekening houdend dat deze code verder opgebouwd moet worden tot kolom AF. (If Range ("AF28").Value= "A" Then

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

    Application.EnableEvents = False

    If Not Application.Intersect(Target, Range("B4:AE19")) Is Nothing Then

        Target(1).Value = UCase(Target(1).Value)
        
        Range("A3") = Now()
        
    End If
    Application.EnableEvents = True

    '==========================================================

    Dim sCellVal As String
    Dim r, r1, r2, r3 As Range, cell As Range, mynumber As Long

    Set r = Range("B6:B19")
    Set r1 = Range("C6:C19")
    Set r2 = Range("D6:D19")
    Set r3 = Range("E6:E19")



    'voegt 2 toe indien in kolom B de 2 laatste cellen leeg zijn


    If Range("B28").Value = "A" Then

        mynumber = 2
        For Each cell In r

            If cell.Value = "" Then
                cell.Value = mynumber

            End If
        Next
    End If

    'voegt 2 toe indien in kolom C de 2 laatste cellen leeg zijn


    If Range("C28").Value = "A" Then

        mynumber = 2
        For Each cell In r1

            If cell.Value = "" Then
                cell.Value = mynumber

            End If
        Next
    End If

    'voegt 2 toe indien in kolom D de 2 laatste cellen leeg zijn


    If Range("D28").Value = "A" Then

        mynumber = 2
        For Each cell In r2

            If cell.Value = "" Then
                cell.Value = mynumber

            End If
        Next
    End If

    'voegt 2 toe indien in kolom E de 2 laatste cellen leeg zijn



    If Range("E28").Value = "A" Then

        mynumber = 2
        For Each cell In r3

            If cell.Value = "" Then
                cell.Value = mynumber

            End If
        Next
    End If


End Sub

Alvast bedankt,

Mvg.
Marc

 

[HSV]

Test het maar eens.

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim arr As Range, cl As Range
Application.EnableEvents = False
    If Not Intersect(Target, Range("B4:AE19")) Is Nothing Then
        Target.Value = UCase(Target.Value)
        Range("A3") = Now()
    End If
'==========================================================
    'voegt 2 toe indien in kolom B de 2 laatste cellen leeg zijn
 For Each arr In Range("B6:B19,C6:C19,D6:D19,E6:E19").Areas
   If arr(1).Offset(22).Value = "A" Then
        For Each cl In arr
          If cl = "" Then cl.Value = 2
        Next cl
    End If
 Next arr
Application.EnableEvents = True
End Sub

 

[samabert]

Harry,

Super! Werkt volledig en veel korter, knap gedaan.:thumb:

Heel erg bedankt
Marc

 

[snb]

kan ook dit ?

in plaats van:

For Each cl In arr
  If cl = "" Then cl.Value = 2
Next cl

arr.specialcells(4)=2

of zonder lus:

Range("B6:B19,C6:C19,D6:D19,E6:E19").specialcells(4)=2

 

[HSV]

Die laatste kan echt niet @snb.
Het is afhankelijk van B28 t/m E28 of daar wel of geen A staat.