Posts by KjBox

Payment received, file sent via PM

I have a solution for you, I will PM you with my PayPal details.

I can look at this for you

Do you have access to a system using Office 2010 or Office 365?

It may be worth copying your files to that system and running the code, if the speed is back to what it used to be, then the problem must be to do with Office 2019. In that case I suggest you reach out to microsoft for help.

If you are calling 22 of the 23 macros from just one macro (or calling others from a macro which itself had been called) then you need to set ScreenUpdating to False, Calculation to Manual and Enable Events to False at the start of the macro that calls the first one, and reverse the settings at the end of that macro. Remove all ScreenUpdating, Calculation and EnableEvents code from all the other macros, otherwise you are turning them on and off 23 times instead of just once! That should improve the speed.

You could also try running a VBA Code Cleaning programme, there are quite a number available on the internet, Ribbon Commander is very good as it works for both 32 and 64 Bit systems, whereas most only work on 32 Bit systems.

As you have already discovered, converting as much Object based code as possible to Array based code will make a huge speed improvement.

Try

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
    If Target.Count > 1 Then Exit Sub
    If Target = vbNullString Then Exit Sub
    If Target.Column > 5 And Target.Column < 10 Then
       [p3].Resize(, 6) = Cells(Target.Row, 16).Resize(, 6)
    End If

End Sub

You will probably find that the selected cell does get a yellow border but that border is not visible while the cell is selected because excel has a black border to show the selected cell. Fill does work and show though.

Attached is a file to do what you want, but with a yellow fill rather than a yellow border. The address of your previous selection is stored in Cell F1 which has the Defined Name "PrevADD" (you can use any cell on your sheet which is not being used and name it "PrevAdd", if you set the font colour of that cell to be the same as the cell fill colour then the text will not be visible).

Bold font and yellow fill will be applied to any selected cell that is not empty, you can further refine the code to work only on particular columns or rows, or on a specified range.

The code in the sheet Object Module is

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim r As Range
    Set r = Range([PrevAdd])
    
    With r
        .Font.Bold = 0
        .Interior.Color = xlNone
    End With
    If Target.Address <> [PrevAdd].Address Then
        If Target <> "" Then
                With Target
                    .Font.Bold = 1
                    .Interior.Color = vbYellow
                End With
            [PrevAdd] = Target.Address
        End If
    End If
    
End Sub

Sent you a PM

I can look at this for you

Try yhis

Sub AddOne()
    Dim r As Range
    
    For Each r In ActiveSheet.UsedRange.Columns(1)
        If IsNumeric(r) Then r = r + 1
    Next
    
End Sub

You're welcome

You don't need line 6 of the code either. My amendment to your original code merely added an extra If..Then..End If statement to account for the current month being January. All you need to do is add your code for getting the previous month's data after each "Then".

Possibly something along these lines

If Month(Date) > 1 Then
    If Year(x(i, DtCol)) = Year(Date) And Month(x(i, DtCol)) = Month(Date) - 1 And x(i, 3) = ContAreas(ii) And x(i, 7) = Category And x(i, 8) = InspType Then
    'Your code here
    End If
ElseIf Year(x(i, DtCol)) = Year(Date) - 1 And Month(x(i, DtCol)) = 12 And x(i, 3) = ContAreas(ii) And x(i, 7) = Category And x(i, 8) = InspType Then
    'Your code here
    End If
End If

ok ty, Roy

Not sure if Roy is looking at this for you or not, I can if he isn't

Try this.

My code will generate a string of Email recipients who meet the combo box criteria. That string can then be parsed to your emailing code to be used in the "To" bit of the code (.To sTo)

Option Explicit

Sub Email_Recipients()
    Dim x, i As Long, sS As String, sP As String, sRecps As String
    
    x = Sheet2.Cells(1).CurrentRegion
    sS = Sheet1.cbSubject: sP = Sheet1.cbPriority
    
    For i = 2 To UBound(x, 1)
        If x(i, 3) = sP And x(i, 9) = sS Then
            If sRecps <> "" Then sRecps = sRecps & x(i, 5) Else sRecps = x(i, 5)
        End If
    Next
    If Len(sRecps) Then Send_Email_Excel_Attachment_Early_Binding sRecps
            
End Sub


Sub Send_Email_Excel_Attachment_Early_Binding(sTo As String)

   MsgBox "I will write code for outlook here"
   

End Sub

Try the attached.

On Sheet 1 the cell linked to the List Box is E2, The list of weekdays starting in J2 is used to populate the list box (you can move it anywhere, even to a hidden sheet, it is a named range "Days". That named range is also used in the code.

The code assigned to the ListBox is

Sub ListBox_Change()
    Const lRow As Long = 7
    Dim lCol As Long
    
    With Sheet2
        lCol = .Cells(lRow, .Columns.Count).End(xlToLeft).Column
        If Len(.Cells(lRow, lCol)) Then lCol = lCol + 1
        .Cells(lRow, lCol) = [Days].Rows([e2])
        .Activate
    End With
    Sheet1.[e2] = 0
    
End Sub

The code will depend upon whether you are using a Form Control Listbox or an ActiveX one. Attach your workbook

Alternatively try the attached, click the button on Sheet 1.

Code assigned to the button:

Sub OrganiseData()
    Dim x, y, i As Long, ii As Long, iii As Long
    x = Sheet1.Cells(1).CurrentRegion
    ReDim y(1 To UBound(x, 1) / 8, 1 To 8)
    
    For i = 1 To UBound(x, 1) Step 8
        ii = ii + 1: iv = i - 1
        For iii = 1 To 8
            y(ii, iii) = x(iii, 1)
        Next
    Next
    With Sheet2
        .Cells(1).CurrentRegion.Clear
        With .[a1].Resize(UBound(y, 1), 8)
            .Value = y
            With .Columns(5).Resize(, 2)
                .NumberFormat = "h:mm"
                .HorizontalAlignment = -4131
            End With
            .Columns(8).Font.Color = RGB(107, 165, 58)
        End With
            .Activate
            .Columns.AutoFit
            Application.Goto .[a1]
    End With
    
End Sub

Why is Row 1 of Sheet1 like it is?