Posts by rollis13

Found this snippet in my 'desk drawer' and I think it's what you need:

Option Explicit
Sub GenerateColors()
    Dim cell   As Range
    Dim iRGB   As Long
    For Each cell In Range("A2", Cells(Rows.Count, "A").End(xlUp))
        With Rows(cell.Row).Cells
            iRGB = RGB(.Range("A1").Value, .Range("B1").Value, .Range("C1").Value)
            .Range("D1").Value = "&H" & Right("000000" & Hex(iRGB), 6)
            .Range("E1").Interior.Color = iRGB
        End With
    Next cell
End Sub

Glad having been of some help.

If those cells are imported maybe you could work on it to have them formatted the way you need them.

That's because many of your cells in column A of sheet MOOZ.A are formatted as text. If your option is activated in most cells you will see a little green triangle on top left and if you select the cell you will see a small yellow popup describing what Excel considers an error (numeric characters should be numbers). If you select 'Convert to number' and your formula in sheet MOOZ.F will give a result.

To fix the entire column in MOOR.A select a cell with a triangle, press Ctrl+Space to highlight the cells, on top of the column you will find the popup where you can choose 'Convert to number'.

I think I'm not wrong if I say that the selected cell border color simply cannot be adjusted since there is no such option in Excel. It will always have the color given by the theme of the operating system. You can see the border change color only after changing cell. I suggest focusing on the background color and bold font to highlight the activecell.

Quote from hamptongolfer11

I will have to try and find a work around to use the keypad

I think it will be useless if you have a Windows x64, the NumLock bug I indicated will 'get you trouble'.

This is a long time issue so I don't understand why it never has been fixed. Don't Win x64 users use SendKeys anymore ?

Hi to all.

hamptongolfer11, have a try with what I came up.

I'm using function OnKeys to launch a macro to show the key pressed and add a Tab key. This macro is only for 0 to 9, nothing to do with Numeric keypad since they have a different coding and to all the other keys of the keyboard. If needed you can implement them (and fix any other bug ).

To move through the cells the best I could do was to lock the other cells and then lock the sheet. Doing so there would be no reason to use "If Not Intersect..." in the event Worksheet_SelectionChange but since it's a couple of hours I'm banging my head there it is and there it remains .

There also is a problem with NumLock key but that's a Windows x64 problem, you can see my workaround.

So, macro Worksheet_SelectionChange in the module of the sheet and the other macros in a standard module:

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim KeysArray As Variant
    Dim MacrosArray As Variant
    Dim x      As Integer
    Dim Key    As Variant
    KeysArray = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9")
    MacrosArray = Array("zero", "one", "two", "three", "four", "five", "six", "seven", "eight", "nine")
    If Not Intersect(Target, Range("C5:K19,M5:U19")) Is Nothing Then
        For x = 0 To 9
            Application.OnKey KeysArray(x), MacrosArray(x) 'enable OnKey function
        Next x
    Else
        For Each Key In KeysArray
            Application.OnKey Key                 'disable OnKey function
        Next Key
    End If
    '(only x64) restore the condition of NumLock since if active it is disabled due to a bug
    DoEvents
    SendKeys "{NUMLOCK}{NUMLOCK}"
End Sub

Option Explicit
Sub zero()
    ActiveCell = Chr(48): Application.SendKeys ("{TAB}")
End Sub
Sub one()
    ActiveCell = Chr(49): Application.SendKeys ("{TAB}")
End Sub
Sub two()
    ActiveCell = Chr(50): Application.SendKeys ("{TAB}")
End Sub
Sub three()
    ActiveCell = Chr(51): Application.SendKeys ("{TAB}")
End Sub
Sub four()
    ActiveCell = Chr(52): Application.SendKeys ("{TAB}")
End Sub
Sub five()
    ActiveCell = Chr(53): Application.SendKeys ("{TAB}")
End Sub
Sub six()
    ActiveCell = Chr(54): Application.SendKeys ("{TAB}")
End Sub
Sub seven()
    ActiveCell = Chr(55): Application.SendKeys ("{TAB}")
End Sub
Sub eight()
    ActiveCell = Chr(56): Application.SendKeys ("{TAB}")
End Sub
Sub nine()
    ActiveCell = Chr(57): Application.SendKeys ("{TAB}")
End Sub

Use the Macro Recoder to compile your new macro, elsewise, post your macro that you use to delete rows with blank M column if you need other help.

Thanks for the feedback, glad I was able to help.

The code was written to be used in a Form with Textboxes, not for a Double-Click but I'm sure that if you do these changes you should be able to use it with an Activecell input.

Open the code pane of the Form named frm_Cal and then from the 'Edit' menu choose 'Replace...' and input as 'Search:'

Me.TextBox1.Value

and input as 'Replace With:'

Activecell

be sure that the only checked is 'Current Module' then click 'Replace All'; you should get n.42 substitutions made.

That's all, enjoy.

Sorry, what the calendar does isn't my job; for this please refer to the original source, maybe you only left out some other piece of code.

Paste this code in the Sheet1's module and it will call the calender when double-clicking in column A:

Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Range("A:A")) Is Nothing Then
        Cancel = True
        frm_Cal.Show
    End If
End Sub

Glad I was able to help.

As said in post #4 you need to change 3 lines of your code to manage a different column or more than one.

If Target.Column <> 1 And Target.Column <> 5 Then Exit Sub
...
XDD = Cells(Target.Row + XD - 1, Target.Column).Value
...
Cells(Target.Row + XD - 1, Target.Column).Value = Replace(Cells(Target.Row + XD - 1, Target.Column), krt, "")

Since I said "1 = A" then "5 = E" so these lines of code become:

If Target.Column <> 5 Then Exit Sub
...
XDD = Cells(Target.Row + XD - 1, 5).Value
...
Cells(Target.Row + XD - 1, 5).Value = Replace(Cells(Target.Row + XD - 1, 5), krt, "")

Here is where the macro forces which column to use 1=A: If Target.Column <> 1 Then Exit Sub

If you use On Error Resume Nextyou must be very carefull with your spelling.

Have you tried:

.SpecialCells(xlCellTypeBlanks).EntireRow.Delete

instead of:

.SpecialCells(xlCellTypeBlanks).EntierRow.Delete

Make these two changes I marked and then move the macro to the ThisWorkBook module. It will then work on every sheet.

Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) '<- changed
    Const WS_RANGE As String = "B3:U268"
    On Error GoTo ws_exit:
    Application.EnableEvents = False
    If Not Intersect(Target, Range(WS_RANGE)) Is Nothing Then '<- changed
        With Target
            If IsNumeric(.Value) And .Value >= 0.01 Then
                .Value = (Int(.Value) + (.Value - Int(.Value)) * 100 / 60) / 24
                .NumberFormat = "[h]:[m]"
            End If
        End With
    End If
ws_exit:
    Application.EnableEvents = True
End Sub

Glad having been of some help.

Have a try with this macro to be copied into the ThisWorkbook module. Every time you open the workbook it will check column B and D; if B is checked (1) and D is major than Today it will delete the row.

Private Sub Workbook_Open()
    Dim lastRow As Long
    Dim i      As Long
    Application.ScreenUpdating = False
    With Worksheets(1)                            'change sheet (Name) to suit
        lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row 'last used row column B
        For i = lastRow To 6 Step -1              'loop from last row to row #6
            If .Cells(i, "B") = 1 And Date > .Cells(i, "D").Value Then 'if date is older than expiration date...
                .Rows(i).Delete                   '...delete the row
            End If
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

Copy this macro in the sheets vbe module and give it a try:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim borderArray, Edge
    If Target.Cells.Count > 1 Then Exit Sub
    If Target.Value <> "" Then
        borderArray = Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight)
        For Edge = 0 To 3
            With Target.Borders(borderArray(Edge))
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
        Next Edge
    End If
End Sub