Excel VBA - Formatting Range

J

jessmoore78

New Member
Joined
Sep 13, 2015
Messages
8
Hello everyone,

i am trying to speed up some code I am working on and have a question. The sheet is a log with internal and external worker hours. Unfortunately I can't completely redo the list because it would cause mass hysteria. ;) So I am pretty much just trying to work around it. I format all of the sheets with the same type of format and there are no other problems with the other sheets because I can grab the range from the beginning of the row to the end (last column or curColumn in code) but the workers sheet is different because it has drop down lists and formulas (sums) in certain columns. I just keep resetting the range and adding the format which causes the code to take alot longer. I was wondering if there was maybe a better way of doing this. Here is the code. I have only listed the non standard variable. "i" and "ws" is standard stuff.

Code: 
Dim dataRange As Range
Dim curColumn As Integer 'the last column to be formatted in the current sheet

'Check the data Range due to inconsistencies in the format so that it doesn't overwrite important cells
                            Select Case ws.Name 'THIS CODE IS SLOW
                                Case "Headcount"
                                    Set dataRange = ws.Range(ws.Cells(i, 4), ws.Cells(i, 5))
                                        dataRange.Value = ""
                                    Set dataRange = ws.Range(ws.Cells(i, 7), ws.Cells(i, 9))
                                        dataRange.Value = ""
                                    Set dataRange = ws.Range(ws.Cells(i, 11), ws.Cells(i, 13))
                                        dataRange.Value = ""
                                    Set dataRange = ws.Range(ws.Cells(i, 15), ws.Cells(i, 17))
                                        dataRange.Value = ""
                                    Set dataRange = ws.Range(ws.Cells(i, 19), ws.Cells(i, 21))
                                        dataRange.Value = ""
                                    Set dataRange = ws.Range(ws.Cells(i, 23), ws.Cells(i, curColumn))
                                        dataRange.Value = ""
                                Case Else
                                    Set dataRange = ws.Range(ws.Cells(i, 4), ws.Cells(i, curColumn))
                                    dataRange.Value = ""
                            End Select
                        Else
                            'Format to Grey
                            columnRange.Interior.Color = RGB(217, 217, 217)
                            'Check the data Range due to inconsistencies in the format so that it doesn't overwrite important cells
                            Select Case ws.Name 'THIS CODE IS SLOW
                                Case "Headcount"
                                    Set dataRange = ws.Range(ws.Cells(i, 4), ws.Cells(i, 5))
                                        dataRange.Value = "-"
                                    Set dataRange = ws.Range(ws.Cells(i, 7), ws.Cells(i, 9))
                                        dataRange.Value = "-"
                                    Set dataRange = ws.Range(ws.Cells(i, 11), ws.Cells(i, 13))
                                        dataRange.Value = "-"
                                    Set dataRange = ws.Range(ws.Cells(i, 15), ws.Cells(i, 17))
                                        dataRange.Value = "-"
                                    Set dataRange = ws.Range(ws.Cells(i, 19), ws.Cells(i, 21))
                                        dataRange.Value = "-"
                                    Set dataRange = ws.Range(ws.Cells(i, 23), ws.Cells(i, curColumn))
                                        dataRange.Value = "-"
                                Case Else
                                    Set dataRange = ws.Range(ws.Cells(i, 4), ws.Cells(i, curColumn))
                                    dataRange.Value = "-"
                            End Select
                        End If

I was thinking about running a for each through every cell in the range with a counter that excludes certain cells through select case but I don't think that would be much faster. Would be greatfull for any help anyone could provide. Thanks!
 

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.
Sort by date Sort by votes
Could you supply the entire code?
It's very difficult to speed up code if we cannot see it ;)
 
Upvote 0
Yes, of course. Sorry but I didn't think the rest was relevant.^^

Code: 
Private Sub UserForm_Initialize()


End Sub

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)

'Check to see if user has entered a date
If Not IsDate(TextBox1.Value) Then
    MsgBox "Start date must be input in a date format tt.mm.jjjj)"
    TextBox1.Value = ""
End If
  
End Sub

Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)

'Check to see if user has entered a date
If Not IsDate(TextBox1.Value) Then
    MsgBox "End date must be input in a date format tt.mm.jjjj)"
    TextBox1.Value = ""
End If
  
End Sub


Private Sub CommandButton1_Click()

'Setup the variables
Dim startDate As Date
Dim endDate As Date
Dim tempDate As Date
Dim curRow As Integer
Dim curColumn As Integer
Dim ws As Worksheet
Dim tempRow As Integer
Dim rCell As Integer
Dim cCell As Integer
Dim rowRange As Range
Dim columnRange As Range
Dim Cell As Range
Dim i As Integer
Dim wkDay As Boolean
Dim dataRange As Range
Dim lastRow As Integer
Dim LastColumn As Integer
Dim curMonth As Integer
Dim monColumn As Integer
Dim monRow As Integer
Dim curMonName As String
Dim cellRange As Range
Dim colLetter As String
Dim curYear As String
Dim sumCheckStart As String
Dim sumCheckEnd As String
Dim checkRange As String

Application.ScreenUpdating = False

'Check that end date isn't before the start date
If CDate(TextBox1.Value) > CDate(TextBox2.Value) Then
    MsgBox "Please check your date inputs, start date is after the end date."
Else
    'Check that the dates aren't empty
    If TextBox1.Value = "" Or TextBox2.Value = "" Then
        MsgBox "Dates are missing"
    Else
        'Continue with formating code
        startDate = TextBox1.Value 'Variable for the start date
        endDate = TextBox2.Value 'Variable for the end date
        curRow = 2 'Variable for the current row to be edited
        curColumn = 1 'Variable for the current column to be edited
        tempRow = curRow 'variable counter for the rows
        
        'Setup the calender
        For tempDate = startDate To endDate
           Tabelle15.Cells(tempRow, curColumn).Value = tempDate
           tempRow = tempRow + 1
        Next tempDate
           
        'Reset the temp counter "based on where the calender should start"
        tempRow = 12
        'Count how many rows need to be formatted
        Do Until Tabelle15.Cells(tempRow, 1).Value = ""
            tempRow = tempRow + 1
        Loop
        'Set tempRow back 1
        tempRow = tempRow - 1
        'Format the cells that need it based on the days worked
        For Each ws In ThisWorkbook.Worksheets
            Select Case ws.Name
                'Pick the sheets that do not need formating
                Case "****pit", "Quality", "Material", "Variables"
                    'Do Nothing
                Case Else
                    'Setup the column span of each worksheet
                    Select Case ws.Name
                        Case "Site Infrastructure"
                            curColumn = 9
                        Case "Civil Works"
                            curColumn = 17
                        Case "Mechanical Works"
                            curColumn = 15
                        Case "Electric DC"
                            curColumn = 19
                        Case "Electric AC & Commissioning"
                            curColumn = 11
                        Case "SCADA"
                            curColumn = 15
                        Case "Non PV"
                            curColumn = 9
                        Case "Machinery"
                            curColumn = 39
                        Case "Headcount"
                            curColumn = 30
                        Case "Hinderance register"
                            curColumn = 8
                        Case "Accidents & Near Miss Cases"
                            curColumn = 13
                    End Select
                    'setup the row counter i
                    i = 12
                    'Setup the range
                    Set rowRange = ws.Range(ws.Cells(12, 1), ws.Cells(tempRow, 1))
                    'Run through the rows and format
                    For Each Cell In rowRange
                        Set columnRange = ws.Range(ws.Cells(i, 1), ws.Cells(i, curColumn))
                        'Set dataRange = ws.Range(ws.Cells(i, 4), ws.Cells(i, curColumn))
                        'Check if it is a working day or not
                        If OptionButton1.Value And Weekday(ws.Cells(i, 3).Value) = 2 Then
                            wkDay = True
                        ElseIf OptionButton2.Value And Weekday(ws.Cells(i, 3).Value) = 3 Then
                            wkDay = True
                        ElseIf OptionButton3.Value And Weekday(ws.Cells(i, 3).Value) = 4 Then
                            wkDay = True
                        ElseIf OptionButton4.Value And Weekday(ws.Cells(i, 3).Value) = 5 Then
                            wkDay = True
                        ElseIf OptionButton5.Value And Weekday(ws.Cells(i, 3).Value) = 6 Then
                            wkDay = True
                        ElseIf OptionButton6.Value And Weekday(ws.Cells(i, 3).Value) = 7 Then
                            wkDay = True
                        ElseIf OptionButton7.Value And Weekday(ws.Cells(i, 3).Value) = 1 Then
                            wkDay = True
                        Else
                            wkDay = False
                        End If
                        'Format the columnRange
                        If wkDay = True Then
                            'Format to White
                            columnRange.Interior.Color = RGB(255, 255, 255)
                            'Check the data Range due to inconsistencies in the format so that it doesn't overwrite important cells
                            Select Case ws.Name 'THIS CODE IS SLOW
                                Case "Headcount"
                                    Set dataRange = ws.Range(ws.Cells(i, 4), ws.Cells(i, 5))
                                        dataRange.Value = ""
                                    Set dataRange = ws.Range(ws.Cells(i, 7), ws.Cells(i, 9))
                                        dataRange.Value = ""
                                    Set dataRange = ws.Range(ws.Cells(i, 11), ws.Cells(i, 13))
                                        dataRange.Value = ""
                                    Set dataRange = ws.Range(ws.Cells(i, 15), ws.Cells(i, 17))
                                        dataRange.Value = ""
                                    Set dataRange = ws.Range(ws.Cells(i, 19), ws.Cells(i, 21))
                                        dataRange.Value = ""
                                    Set dataRange = ws.Range(ws.Cells(i, 23), ws.Cells(i, curColumn))
                                        dataRange.Value = ""
                                Case Else
                                    Set dataRange = ws.Range(ws.Cells(i, 4), ws.Cells(i, curColumn))
                                    dataRange.Value = ""
                            End Select
                        Else
                            'Format to Grey
                            columnRange.Interior.Color = RGB(217, 217, 217)
                            'Check the data Range due to inconsistencies in the format so that it doesn't overwrite important cells
                            Select Case ws.Name 'THIS CODE IS SLOW
                                Case "Headcount"
                                    Set dataRange = ws.Range(ws.Cells(i, 4), ws.Cells(i, 5))
                                        dataRange.Value = "-"
                                    Set dataRange = ws.Range(ws.Cells(i, 7), ws.Cells(i, 9))
                                        dataRange.Value = "-"
                                    Set dataRange = ws.Range(ws.Cells(i, 11), ws.Cells(i, 13))
                                        dataRange.Value = "-"
                                    Set dataRange = ws.Range(ws.Cells(i, 15), ws.Cells(i, 17))
                                        dataRange.Value = "-"
                                    Set dataRange = ws.Range(ws.Cells(i, 19), ws.Cells(i, 21))
                                        dataRange.Value = "-"
                                    Set dataRange = ws.Range(ws.Cells(i, 23), ws.Cells(i, curColumn))
                                        dataRange.Value = "-"
                                Case Else
                                    Set dataRange = ws.Range(ws.Cells(i, 4), ws.Cells(i, curColumn))
                                    dataRange.Value = "-"
                            End Select
                        End If
                        'add 1 to i for the next row
                        i = i + 1
                    Next Cell
                    'Reset the temp counter
            End Select
        Next ws
            
        
'        'Let the user know that this process will take a while to complete
'        MsgBox "The formatting will take a few minutes depending on calender length, please be patient."


        'Headcount Monthly Hour Overview Setup
        curRow = 12
        curColumn = 3
        lastRow = 12
        LastColumn = 31
        monRow = 2
        monColumn = 4

        With Tabelle12

            curMonth = Month(.Cells(curRow, curColumn).Value)
            curYear = Year(.Cells(curRow, curColumn).Value)
    
            Select Case curMonth
                Case 1
                    curMonName = "Jan"
                Case 2
                    curMonName = "Feb"
                Case 3
                    curMonName = "Mar"
                Case 4
                    curMonName = "Apr"
                Case 5
                    curMonName = "May"
                Case 6
                    curMonName = "Jun"
                Case 7
                    curMonName = "Jul"
                Case 8
                    curMonName = "Aug"
                Case 9
                    curMonName = "Sep"
                Case 10
                    curMonName = "Oct"
                Case 11
                    curMonName = "Nov"
                Case 12
                    curMonName = "Dec"
            End Select
    
            'Setup first month/year combo for the overview
            .Cells(monRow, monColumn).Value = CStr(curMonName & " " & curYear)
            'Append the variables for the formula
            sumCheckStart = .Cells(12, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False)
            sumCheckEnd = .Cells(1000, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False)
            'Add the formula
            checkRange = .Cells(monRow, monColumn).Address(RowAbsolute:=False, ColumnAbsolute:=False)
            .Cells(monRow + 1, monColumn).Formula = "=SUMPRODUCT((MONTH(" & sumCheckStart & ":" & _
            sumCheckEnd & ")=MONTH(" & checkRange & "))*(YEAR(" & sumCheckStart & ":" & sumCheckEnd & ")=YEAR(" & _
            checkRange & "))*(F12:F1000)+(J12:J1000)+(N12:N1000)+(R12:R1000)+(V12:V1000))"
    
            'Add the rest of the years afterwards
            Do Until .Cells(curRow, curColumn).Value = ""
                lastRow = lastRow + 1
                curRow = curRow + 1
                'Code to calculate the amount of months there are
                If Month(.Cells(curRow, curColumn).Value) <> curMonth Then
                    'totalMonths = totalMonths + 1
                    curMonth = Month(.Cells(curRow, curColumn).Value)
                    curYear = Year(.Cells(curRow, curColumn).Value)
                    monColumn = monColumn + 1
    
                    Select Case curMonth
                        Case 1
                            curMonName = "Jan"
                        Case 2
                            curMonName = "Feb"
                        Case 3
                            curMonName = "Mar"
                        Case 4
                            curMonName = "Apr"
                        Case 5
                            curMonName = "May"
                        Case 6
                            curMonName = "Jun"
                        Case 7
                            curMonName = "Jul"
                        Case 8
                            curMonName = "Aug"
                        Case 9
                            curMonName = "Sep"
                        Case 10
                            curMonName = "Oct"
                        Case 11
                            curMonName = "Nov"
                        Case 12
                            curMonName = "Dec"
                    End Select
    
                    'Setup Monthly overview
                    .Cells(monRow, monColumn).Value = CStr(curMonName & " " & curYear)
                    'Append the variables for the formula
                    sumCheckStart = .Cells(12, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False)
                    sumCheckEnd = .Cells(1000, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False)
                    'Add the formula
                    checkRange = .Cells(monRow, monColumn).Address(RowAbsolute:=False, ColumnAbsolute:=False)
                    .Cells(monRow + 1, monColumn).Formula = "=SUMPRODUCT((MONTH(" & sumCheckStart & ":" & _
                    sumCheckEnd & ")=MONTH(" & checkRange & "))*(YEAR(" & sumCheckStart & ":" & sumCheckEnd & ")=YEAR(" & _
                    checkRange & "))*(F12:F1000))+SUMPRODUCT((MONTH(" & sumCheckStart & ":" & _
                    sumCheckEnd & ")=MONTH(" & checkRange & "))*(YEAR(" & sumCheckStart & ":" & sumCheckEnd & ")=YEAR(" & _
                    checkRange & "))*(J12:J1000))+SUMPRODUCT((MONTH(" & sumCheckStart & ":" & _
                    sumCheckEnd & ")=MONTH(" & checkRange & "))*(YEAR(" & sumCheckStart & ":" & sumCheckEnd & ")=YEAR(" & _
                    checkRange & "))*(N12:N1000))+SUMPRODUCT((MONTH(" & sumCheckStart & ":" & _
                    sumCheckEnd & ")=MONTH(" & checkRange & "))*(YEAR(" & sumCheckStart & ":" & sumCheckEnd & ")=YEAR(" & _
                    checkRange & "))*(R12:R1000))+SUMPRODUCT((MONTH(" & sumCheckStart & ":" & _
                    sumCheckEnd & ")=MONTH(" & checkRange & "))*(YEAR(" & sumCheckStart & ":" & sumCheckEnd & ")=YEAR(" & _
                    checkRange & "))*(V12:V1000))"
    
                End If
            Loop
    
            Tabelle12.Activate
    
            'Put the totals column in place
            .Cells(monRow, monColumn).Value = "Total"
            For Each cellRange In Tabelle12.Range(Cells(monRow, 2), Cells(monRow, monColumn))
                cellRange.Font.Bold = True
                cellRange.Font.Size = 16
                cellRange.Font.Name = "Cambria"
                cellRange.Interior.Color = RGB(204, 204, 204)
                cellRange.Borders.LineStyle = xlContinuous
                cellRange.Borders.Weight = xlMedium
    
                For i = 1 To 5
                    cellRange.Offset(RowOffset:=i).Font.Bold = True
                    cellRange.Offset(RowOffset:=i).Font.Size = 12
                    cellRange.Offset(RowOffset:=i).Font.Name = "Cambria"
                    cellRange.Offset(RowOffset:=i).Interior.ColorIndex = 2
                    cellRange.Offset(RowOffset:=i).Borders.LineStyle = xlContinuous
                    cellRange.Offset(RowOffset:=i).Borders.Weight = xlMedium
                Next i
            Next cellRange
    
            With .Cells(monRow, monColumn)
                For i = 1 To 5
                    colLetter = .Offset(RowOffset:=i, ColumnOffset:=-1).Address(RowAbsolute:=False, ColumnAbsolute:=False)
                    .Offset(RowOffset:=i).Formula = "=SUM(D" & i + 2 & ":" & colLetter & ")"
                Next i
            End With
        End With

        'Close the userform
        Unload Me
    
    End If
    
End If

Application.ScreenUpdating = True

End Sub
 
Upvote 0
Not sure this will speed things up much, but try
Code: 
Private Sub CommandButton1_Click()

'Setup the variables
Dim startDate As Date
Dim endDate As Date
Dim tempDate As Date
Dim curRow As Integer
Dim curColumn As Integer
Dim ws As Worksheet
Dim tempRow As Integer
Dim rCell As Integer
Dim cCell As Integer
Dim rowRange As Range
Dim columnRange As Range
Dim Cell As Range
Dim i As Integer
Dim wkDay As Boolean
Dim dataRange As Range
Dim lastRow As Integer
Dim LastColumn As Integer
Dim curMonth As Integer
Dim monColumn As Integer
Dim monRow As Integer
Dim curMonName As String
Dim cellRange As Range
Dim colLetter As String
Dim curYear As String
Dim sumCheckStart As String
Dim sumCheckEnd As String
Dim checkRange As String

Application.ScreenUpdating = False

'Check that end date isn't before the start date
If CDate(TextBox1.Value) > CDate(TextBox2.Value) Then
    MsgBox "Please check your date inputs, start date is after the end date."
    Exit Sub
End If
'Check that the dates aren't empty
If TextBox1.Value = "" Or TextBox2.Value = "" Then
    MsgBox "Dates are missing"
    Exit Sub
End If
    'Continue with formating code
    startDate = TextBox1.Value 'Variable for the start date
    endDate = TextBox2.Value 'Variable for the end date
    curRow = 2 'Variable for the current row to be edited
    curColumn = 1 'Variable for the current column to be edited
    tempRow = curRow 'variable counter for the rows
    
    'Setup the calender
    For tempDate = startDate To endDate
       Tabelle15.Cells(tempRow, curColumn).Value = tempDate
       tempRow = tempRow + 1
    Next tempDate
       
    'Reset the temp counter "based on where the calender should start"
    tempRow = 12
    'Count how many rows need to be formatted
    Do Until Tabelle15.Cells(tempRow, 1).Value = ""
        tempRow = tempRow + 1
    Loop
    'Set tempRow back 1
    tempRow = tempRow - 1
    'Format the cells that need it based on the days worked
    For Each ws In ThisWorkbook.Worksheets
        Select Case ws.Name
            'Pick the sheets that do not need formating
            Case "****pit", "Quality", "Material", "Variables"
                'Do Nothing
            Case Else
                'Setup the column span of each worksheet
                Select Case ws.Name
                    Case "Site Infrastructure"
                        curColumn = 9
                    Case "Civil Works"
                        curColumn = 17
                    Case "Mechanical Works"
                        curColumn = 15
                    Case "Electric DC"
                        curColumn = 19
                    Case "Electric AC & Commissioning"
                        curColumn = 11
                    Case "SCADA"
                        curColumn = 15
                    Case "Non PV"
                        curColumn = 9
                    Case "Machinery"
                        curColumn = 39
                    Case "Headcount"
                        curColumn = 30
                    Case "Hinderance register"
                        curColumn = 8
                    Case "Accidents & Near Miss Cases"
                        curColumn = 13
                End Select
                'Run through the rows and format
                For i = 12 To tempRow
                    Set columnRange = ws.Range(ws.Cells(i, 1), ws.Cells(i, curColumn))
                    'Check if it is a working day or not
                    If OptionButton1.Value And Weekday(ws.Cells(i, 3).Value) = 2 Then
                        wkDay = True
                    ElseIf OptionButton2.Value And Weekday(ws.Cells(i, 3).Value) = 3 Then
                        wkDay = True
                    ElseIf OptionButton3.Value And Weekday(ws.Cells(i, 3).Value) = 4 Then
                        wkDay = True
                    ElseIf OptionButton4.Value And Weekday(ws.Cells(i, 3).Value) = 5 Then
                        wkDay = True
                    ElseIf OptionButton5.Value And Weekday(ws.Cells(i, 3).Value) = 6 Then
                        wkDay = True
                    ElseIf OptionButton6.Value And Weekday(ws.Cells(i, 3).Value) = 7 Then
                        wkDay = True
                    ElseIf OptionButton7.Value And Weekday(ws.Cells(i, 3).Value) = 1 Then
                        wkDay = True
                    Else
                        wkDay = False
                    End If
                    'Format the columnRange
                    If wkDay = True Then
                        'Format to White
                        columnRange.Interior.Color = RGB(255, 255, 255)
                        'Check the data Range due to inconsistencies in the format so that it doesn't overwrite important cells
                        If ws.Name = "Headcount" Then
                           ws.Range(ws.Cells(i, 4), ws.Cells(i, 5)).Value = ""
                           ws.Range(ws.Cells(i, 7), ws.Cells(i, 9)).Value = ""
                           ws.Range(ws.Cells(i, 11), ws.Cells(i, 13)).Value = ""
                           ws.Range(ws.Cells(i, 15), ws.Cells(i, 17)).Value = ""
                           ws.Range(ws.Cells(i, 19), ws.Cells(i, 21)).Value = ""
                           ws.Range(ws.Cells(i, 23), ws.Cells(i, curColumn)).Value = ""
                        Else
                           ws.Range(ws.Cells(i, 4), ws.Cells(i, curColumn)).Value = ""
                        End If
                    Else
                        'Format to Grey
                        columnRange.Interior.Color = RGB(217, 217, 217)
                        'Check the data Range due to inconsistencies in the format so that it doesn't overwrite important cells
                        If ws.Name = "Headcount" Then
                           ws.Range(ws.Cells(i, 4), ws.Cells(i, 5)).Value = "-"
                           ws.Range(ws.Cells(i, 7), ws.Cells(i, 9)).Value = "-"
                           ws.Range(ws.Cells(i, 11), ws.Cells(i, 13)).Value = "-"
                           ws.Range(ws.Cells(i, 15), ws.Cells(i, 17)).Value = "-"
                           ws.Range(ws.Cells(i, 19), ws.Cells(i, 21)).Value = "-"
                           ws.Range(ws.Cells(i, 23), ws.Cells(i, curColumn)).Value = "-"
                        Else
                           ws.Range(ws.Cells(i, 4), ws.Cells(i, curColumn)).Value = "-"
                        End If
                    End If
                Next i
        End Select
    Next ws
        
    
'        'Let the user know that this process will take a while to complete
'        MsgBox "The formatting will take a few minutes depending on calender length, please be patient."


    'Headcount Monthly Hour Overview Setup
    curRow = 12
    curColumn = 3
    lastRow = 12
    LastColumn = 31
    monRow = 2
    monColumn = 4

    With Tabelle12

        curMonth = Month(.Cells(curRow, curColumn).Value)
        curYear = Year(.Cells(curRow, curColumn).Value)

        Select Case curMonth
            Case 1
                curMonName = "Jan"
            Case 2
                curMonName = "Feb"
            Case 3
                curMonName = "Mar"
            Case 4
                curMonName = "Apr"
            Case 5
                curMonName = "May"
            Case 6
                curMonName = "Jun"
            Case 7
                curMonName = "Jul"
            Case 8
                curMonName = "Aug"
            Case 9
                curMonName = "Sep"
            Case 10
                curMonName = "Oct"
            Case 11
                curMonName = "Nov"
            Case 12
                curMonName = "Dec"
        End Select

        'Setup first month/year combo for the overview
        .Cells(monRow, monColumn).Value = CStr(curMonName & " " & curYear)
        'Append the variables for the formula
        sumCheckStart = .Cells(12, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False)
        sumCheckEnd = .Cells(1000, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False)
        'Add the formula
        checkRange = .Cells(monRow, monColumn).Address(RowAbsolute:=False, ColumnAbsolute:=False)
        .Cells(monRow + 1, monColumn).Formula = "=SUMPRODUCT((MONTH(" & sumCheckStart & ":" & _
        sumCheckEnd & ")=MONTH(" & checkRange & "))*(YEAR(" & sumCheckStart & ":" & sumCheckEnd & ")=YEAR(" & _
        checkRange & "))*(F12:F1000)+(J12:J1000)+(N12:N1000)+(R12:R1000)+(V12:V1000))"

        'Add the rest of the years afterwards
        Do Until .Cells(curRow, curColumn).Value = ""
            lastRow = lastRow + 1
            curRow = curRow + 1
            'Code to calculate the amount of months there are
            If Month(.Cells(curRow, curColumn).Value) <> curMonth Then
                'totalMonths = totalMonths + 1
                curMonth = Month(.Cells(curRow, curColumn).Value)
                curYear = Year(.Cells(curRow, curColumn).Value)
                monColumn = monColumn + 1

                Select Case curMonth
                    Case 1
                        curMonName = "Jan"
                    Case 2
                        curMonName = "Feb"
                    Case 3
                        curMonName = "Mar"
                    Case 4
                        curMonName = "Apr"
                    Case 5
                        curMonName = "May"
                    Case 6
                        curMonName = "Jun"
                    Case 7
                        curMonName = "Jul"
                    Case 8
                        curMonName = "Aug"
                    Case 9
                        curMonName = "Sep"
                    Case 10
                        curMonName = "Oct"
                    Case 11
                        curMonName = "Nov"
                    Case 12
                        curMonName = "Dec"
                End Select

                'Setup Monthly overview
                .Cells(monRow, monColumn).Value = CStr(curMonName & " " & curYear)
                'Append the variables for the formula
                sumCheckStart = .Cells(12, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False)
                sumCheckEnd = .Cells(1000, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False)
                'Add the formula
                checkRange = .Cells(monRow, monColumn).Address(RowAbsolute:=False, ColumnAbsolute:=False)
                .Cells(monRow + 1, monColumn).Formula = "=SUMPRODUCT((MONTH(" & sumCheckStart & ":" & _
                sumCheckEnd & ")=MONTH(" & checkRange & "))*(YEAR(" & sumCheckStart & ":" & sumCheckEnd & ")=YEAR(" & _
                checkRange & "))*(F12:F1000))+SUMPRODUCT((MONTH(" & sumCheckStart & ":" & _
                sumCheckEnd & ")=MONTH(" & checkRange & "))*(YEAR(" & sumCheckStart & ":" & sumCheckEnd & ")=YEAR(" & _
                checkRange & "))*(J12:J1000))+SUMPRODUCT((MONTH(" & sumCheckStart & ":" & _
                sumCheckEnd & ")=MONTH(" & checkRange & "))*(YEAR(" & sumCheckStart & ":" & sumCheckEnd & ")=YEAR(" & _
                checkRange & "))*(N12:N1000))+SUMPRODUCT((MONTH(" & sumCheckStart & ":" & _
                sumCheckEnd & ")=MONTH(" & checkRange & "))*(YEAR(" & sumCheckStart & ":" & sumCheckEnd & ")=YEAR(" & _
                checkRange & "))*(R12:R1000))+SUMPRODUCT((MONTH(" & sumCheckStart & ":" & _
                sumCheckEnd & ")=MONTH(" & checkRange & "))*(YEAR(" & sumCheckStart & ":" & sumCheckEnd & ")=YEAR(" & _
                checkRange & "))*(V12:V1000))"

            End If
        Loop

        Tabelle12.Activate

        'Put the totals column in place
        .Cells(monRow, monColumn).Value = "Total"
        For Each cellRange In Tabelle12.Range(Cells(monRow, 2), Cells(monRow, monColumn))
            cellRange.Font.Bold = True
            cellRange.Font.size = 16
            cellRange.Font.Name = "Cambria"
            cellRange.Interior.Color = RGB(204, 204, 204)
            cellRange.Borders.LineStyle = xlContinuous
            cellRange.Borders.Weight = xlMedium

            For i = 1 To 5
                cellRange.Offset(RowOffset:=i).Font.Bold = True
                cellRange.Offset(RowOffset:=i).Font.size = 12
                cellRange.Offset(RowOffset:=i).Font.Name = "Cambria"
                cellRange.Offset(RowOffset:=i).Interior.ColorIndex = 2
                cellRange.Offset(RowOffset:=i).Borders.LineStyle = xlContinuous
                cellRange.Offset(RowOffset:=i).Borders.Weight = xlMedium
            Next i
        Next cellRange

        With .Cells(monRow, monColumn)
            For i = 1 To 5
                colLetter = .Offset(RowOffset:=i, ColumnOffset:=-1).Address(RowAbsolute:=False, ColumnAbsolute:=False)
                .Offset(RowOffset:=i).Formula = "=SUM(D" & i + 2 & ":" & colLetter & ")"
            Next i
        End With
    End With

    'Close the userform
    Unload Me

Application.ScreenUpdating = True

End Sub
 
Upvote 0
Hi Fluff,

thank you for your time, I really appreciate it. I do not notice a real difference at the moment allthough logically thinking, it must have an improvement since you cut out appending the range. I should have done that from the beginning as well. ;p I have already cut off around 3 - 4 minutes in the code through using ranges for the rest so it is no biggie if it can't be more, I have still improved it a whole lot. I was actually running through every single cell at the beginning to format them. Still getting the hang of this VB fun.^^

Anyways, once again thank you for your time and the help.
 
Upvote 0
Glad to help & thanks for the feedback
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question
VBA Graph
Replies
1
Views
335
offthelip
O
S
  • Question
Parse data - Overwrite lines with updated data
Replies
0
Views
160
Scifo
S
A
  • Solved
VBA Help!
Replies
2
Views
139
AusNewb
A
L
  • Question
VBA to export recurring meeting data
Replies
1
Views
697
John_w
J
S
  • Question
Doubleclick on cell in Protected Sheet
Replies
4
Views
363
shoheiyuna
S

Forum statistics

Threads
1,216,456
Messages
6,130,743
Members
449,588
Latest member
accountant606

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top