VBAの色付きセルにのみコードを適用する

Question

私はレシピシートの中に見つかったコードを入力する代わりに、スキャンされたエントリのみを取り入れようとしています。入力が必要なセルはオレンジ色です。私はこれらの細胞がスキャンされたエントリだけを受け入れるようにしたいと思います。これまでは、コード「I」をコードに適用し、それをすべてオレンジ色にすることにしました。私はそれが細胞を着色するのではなく、すでに着色細胞を使用したいと思います。相続人は私がこれまで

---

を持っている...

Option Explicit 

Declare Function SetWindowsHookEx Lib _ 
"user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, _ 
ByVal hmod As Long, ByVal dwThreadId As Long) As Long 
Declare Function CallNextHookEx Lib "user32" _ 
(ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long 

Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long 

Declare Function GetActiveWindow Lib "user32"() As Long 

Declare Function FindWindow Lib "user32" Alias "FindWindowA" _ 
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long 

Const HC_ACTION = 0 
Const WM_KEYDOWN = &H100 
Const WH_KEYBOARD_LL = 13 
Dim hhkLowLevelKybd As Long 
Dim blnHookEnabled As Boolean 
Dim enumAllowedValues As AllowedValues 
Dim objTargetRange As Range 
Dim objValidationRange As Range 
Dim vAns As Variant 

Type KBDLLHOOKSTRUCT 
    vkCode As Long 
    scanCode As Long 
    flags As Long 
    time As Long 
    dwExtraInfo As Long 
End Type 

Enum AllowedValues 
    alpha 
    numeric 
End Enum 




Function LowLevelKeyboardProc _ 
(ByVal nCode As Long, ByVal wParam As Long, lParam As KBDLLHOOKSTRUCT) As Long 

    '\hook keyboard only if XL is the active window 
    If GetActiveWindow = FindWindow("XLMAIN", Application.Caption) Then 
     If (nCode = HC_ACTION) Then 
      '\check if a key is pushed 
      If wParam = WM_KEYDOWN Then 
      '\if so, check if the active cell is within the target range 
       If Union(ActiveCell, objTargetRange).Address = objTargetRange.Address Then 
       '\if only numeric values should be allowed then 
        If enumAllowedValues = 1 Then 
        '\check if the pushed key is a numeric key or a navigation key 
        '\by checking the vkCode stored in the laparm parameter 
         If Chr(lParam.vkCode) Like "#" Or _ 
          lParam.vkCode = 37 Or lParam.vkCode = 38 Or lParam.vkCode = 39 Or _ 
          lParam.vkCode = 40 Or lParam.vkCode = 9 Or lParam.vkCode = 13 Then 
          '\if so allow the input 
          LowLevelKeyboardProc = 0 
         Else 
          '\else filter out this Key_Down message from message qeue 
          Beep 
          LowLevelKeyboardProc = -1 
          Exit Function 
         End If 
         '\if onle alpha values should be allowed then 
        ElseIf enumAllowedValues = 0 Then 
         '\check the laparam parameter 
         If Chr(lParam.vkCode) Like "#" Then 
          '\if numeric prevent the input 
          Beep 
          LowLevelKeyboardProc = -1 
          Exit Function 
         Else 
          '\otherwise allow the input 
          LowLevelKeyboardProc = 0 
        End If 
        End If 
       End If 
      End If 
     End If 
    End If 
    '\pass function to next hook if there is one 
    LowLevelKeyboardProc = CallNextHookEx(0, nCode, wParam, ByVal lParam) 

End Function 


Public Sub Unhook_KeyBoard() 

    If hhkLowLevelKybd <> 0 Then UnhookWindowsHookEx hhkLowLevelKybd 
    blnHookEnabled = False 


End Sub 


Sub ValidateRange(r As Range, ByVal v As AllowedValues) 

    '\store these in global variables for they will be 
    '\needed later in the filter function 
    enumAllowedValues = v 
    Set objTargetRange = r 
    '\don't hook the keyboard twice !! 
    If blnHookEnabled = False Then 
     hhkLowLevelKybd = SetWindowsHookEx _ 
     (WH_KEYBOARD_LL, AddressOf LowLevelKeyboardProc, Application.Hinstance, 0) 
     blnHookEnabled = True 
    End If 

End Sub 


Sub test() 

    '\ignore any mishandling of the following 
    '\input boxes by the user 
    On Error Resume Next 
    Set objValidationRange = Sheets("Sheet1").Range("I:I") 
    If objValidationRange Is Nothing Then GoTo errHdlr 
     objValidationRange.Interior.ColorIndex = 44 
     vAns = 2 
     If vAns = 2 Then 
      ValidateRange objValidationRange, AllowedValues.numeric + alpha 
     Else 
     GoTo errHdlr 
    End If 
    objValidationRange.Cells(1).Select 
    Set objValidationRange = Nothing 
    Exit Sub 
errHdlr: 
    MsgBox "criteria error- Try again !", vbCritical 
    Unhook_KeyBoard 

End Sub 

Answer 1

あなたが変更したいセル/行は確かに、すべての

.Interior.ColorIndex = 44 

を特徴としていることを確認している場合それが正しければロジックを続行してください：

色はシンプルなのColorIndex = 44以外のものである場合、あなたは

?myCell.Interior.Color 

を使用して、それがイミディエイトウィンドウにあるかどうか確認することができますあなたは色の値（それが数値として出力です）とペーストをコピーすることができますあなたの状態では、ColorとColorIndexを区別することを忘れないでください。