Excel - Visual Basic, macro with autofill "1"

Question

My task is to create a tool that, based on (specific) input data, will generate a 'grid' of employees' working hours and spit out specific shifts 6-14; 7-15; 10-20 etc etc.

The general operation of such a macro, let's say I have one, the problem begins when the macro must have a requirement that in a given row (the row is one employee) the sum cannot be greater than 10.

Below I paste the code I managed to create, which fills in the values ​​accordingly based on the input data, but without this requirement (row sum not greater than 10).

Sub AutoFill()
    Dim ws As Worksheet
    Dim col As Integer
    Dim row As Integer
    Dim suma As Integer
    Dim liczba_osob As Integer
    
    ' Ustaw arkusz, na którym chcesz działać
    Set ws = ThisWorkbook.Sheets("01")
    
    ' Wyczyść zakres G5:AD36
    ws.Range("G5:AD36").ClearContents
    
    ' Iteruj przez kolumny od G do Y
    For col = 7 To 30
        ' Pobierz liczbę osób w pracy w danej godzinie
        liczba_osob = ws.Cells(2, col).Value
        
        ' Ustaw sumę kolumny na 0
        suma = 0
        
        ' Uzupełnij komórki wartością 1 do momentu, gdy suma wiersza będzie równa liczbie osób w pracy
        For row = 5 To 36
            ' Sprawdź, czy suma nie przekracza liczby osób w pracy
            If suma < liczba_osob Then
                ws.Cells(row, col).Value = 1
                suma = suma + 1
            Else
                ' Jeśli suma przekroczyła liczbę osób w pracy, zostaw komórkę pustą
                If Not IsEmpty(ws.Cells(row, col)) Then
                    ws.Cells(row, col).ClearContents
                End If
            End If
        Next row
    Next col
End Sub

There are also screenshots below in the attachments - in one there is the addition of "1" by the macro, in the other the addition of "1" by me in the way the macro should be supplemented.

Yes, as part of the implementation, the number of employees in each hour is given in the G2:AD2 range, and the hours are listed in G1:AD1.

Can anyone help me or guide me somehow to make it work?

Unless it is possible to completely omit all these "1"s and directly generate individual changes 6-14, 7-15, etc. based on the demand given in G2:AD2...

I need solution for filling like in screenshot.

Answer 1

it seems to me you could achieve your goal by means of formulas

if you insert one column and one row you could use this formula

=IF(SUM(G$5:G5)<G$2;IF(SUM(F6:$F6)<8;1;"");"")

or you can keep your original rows and columns layout and adopt this other formula:

=IF(ROW()=5;
    IF(COLUMN()=7;
        1;
         IF(SUM(F5:$G5)<8;1;""));
    IF(SUM(G4:G$5)<G$2;
          IF(COLUMN()=7;
               1;
                IF(SUM(F5:$G5)<8;1;""));
          "")
    )

Finally here's the corresponding amendment of your code (forgive the polish):

Sub AutoFill()
    Dim ws As Worksheet
    Dim col As Integer
    Dim row As Integer
    Dim suma As Integer
    Dim liczba_osob As Integer
    
    ' Ustaw arkusz, na którym chcesz dzialac
    Set ws = ThisWorkbook.Sheets("01")
    
    ' Wyczysc zakres G5:AD36
    ws.Range("G5:AD36").ClearContents
    
    ' Iteruj przez kolumny od G do Y
    For col = 7 To 30
        ' Pobierz liczbe osób w pracy w danej godzinie
        liczba_osob = ws.Cells(2, col).Value
        
        ' Ustaw sume kolumny na 0
        suma = 0
        
        ' Uzupelnij komórki wartoscia 1 do momentu, gdy suma wiersza bedzie równa liczbie osób w pracy
        For row = 5 To 36
            ' Sprawdz, czy w biezacym wierszu nie przekracza liczby osób w pracy      '<-----|
            If WorksheetFunction.Sum(ws.Range(ws.Cells(row, 7), ws.Cells(row, WorksheetFunction.Max(7, col - 1)))) < 8 Then '<-----|
                ' Sprawdz, czy suma nie przekracza liczby osób w pracy
                If suma < liczba_osob Then
                    ws.Cells(row, col).Value = 1
                    suma = suma + 1
                End If
            End If '<-----|
        Next row
    Next col
End Sub

and here's a refactoring of that code:

Option Explicit

Sub AutoFill()
    
    Const MAX_HOURS As Long = 8
    Const DATA_ADDRESS As String = "G5:AD36"
    
    With ThisWorkbook.Sheets("01")
    
        Dim dataRng As Range
            Set dataRng = .Range(DATA_ADDRESS)
            
            With dataRng
                Dim firstCol As Long
                    firstCol = .Columns(1).Column
            
                Dim firstRow As Long
                    firstRow = .Rows(1).row
                
                .ClearContents
            End With
        
                Dim columnRng As Range
                    For Each columnRng In dataRng.Columns
            
                        Dim currentCol As Long
                            currentCol = columnRng.Column
                        
                        Dim currentColHoursLimit As Long
                            currentColHoursLimit = .Cells(2, currentCol).Value
                            
                            Dim rowCel As Range
                                For Each rowCel In columnRng.Rows
                                    If WorksheetFunction.Sum(.Range(.Cells(rowCel.row, firstCol), .Cells(rowCel.row, WorksheetFunction.Max(firstCol, currentCol - 1)))) < MAX_HOURS Then
                                        If WorksheetFunction.Sum(.Range(.Cells(firstRow, currentCol), .Cells(WorksheetFunction.Max(firstRow, rowCel.row - 1), currentCol))) < currentColHoursLimit Then
                                            rowCel.Value = 1
                                        End If
                                    End If
                                Next
                    Next
                    
    End With
    
End Sub

Answer 2

• Loading data from cells to an arrya to improve the efficiency

Microsoft documentation:

Range.ClearContents method (Excel)

Range.Offset property (Excel)

ReDim statement

Option Explicit

Sub Demo()
    Dim i As Long, j As Long
    Dim arrData, rngData As Range
    Dim arrRSum, iR As Long, iNum As Long
    Const FIRSTCOL = "G"
    Const FIRSTROW = 5
    Const LASTROW = 36
    Const MAXHR = 10 ' modify as needed
    ' get the table
    Set rngData = Range(Range("F1").End(xlToRight), FIRSTCOL & LASTROW)
    With rngData
        ' clear table
        .Resize(.Rows.Count - FIRSTROW + 1).Offset(FIRSTROW - 1).ClearContents
        ' load data into an arrya
        arrData = .Value
    End With
    ReDim arrRSum(1 To UBound(arrData))
    ' loop throgh Cols
    For j = LBound(arrData, 2) To UBound(arrData, 2)
        iR = 0
        iNum = arrData(2, j)
        If iNum > 0 Then
            ' pupulate the table
            For i = FIRSTROW To UBound(arrData)
                If arrRSum(i) < MAXHR Then
                    arrData(i, j) = 1
                    iR = iR + 1
                    arrRSum(i) = arrRSum(i) + 1
                    If iR = iNum Then Exit For
                End If
            Next
        End If
    Next
    ' write output to sheet
    rngData.Value = arrData
End Sub