GDIplusCODE


	
'一行目は見出し
'A列、B列、C列、D列
'開始、終了、作業、時間 '分単位
'A列Wクリックで開始時間入力、作業内容入力フォーム表示（データはC列に転記）
'B列Wクリックで終了時間入力、D列に所要時間算出
'A,B列時間を手修正した時、時間再計算
'入力フォーム表示状態で、シート上の作業履歴セルをクリックすると、その内容を複写して両フォームを閉じる
'入力フォーム表示状態で、Ctrl + f を押すと、検索フォームを表示
'検索された行のC列の作業履歴セルをクリックすると、その内容を複写して両フォームを閉じる
 
'☆Sheet1　作業記録保存用シート

Private Sub Worksheet_BeforeDoubleClick(ByVal target As Range, Cancel As Boolean)
  Dim rc As VbMsgBoxResult
  Dim belowRowCount As Long
  
  '作業内容入力フォームが隠れのを防止するためだが
  '後からの改造によりシートの上の方で作業する様になり、意味が無くなっている
  With ActiveWindow
    belowRowCount = .VisibleRange.Rows(.VisibleRange.Rows.Count).Row - target.Row
    If belowRowCount <= 6 Then
      .SmallScroll Down:=6 - belowRowCount
    End If
  End With
  
  If target.Column > 2 Then Exit Sub
  If target.Row = 1 Then Exit Sub
  Cancel = True
  
  If target.Value <> "" Then
    rc = MsgBox("既存のデータを上書きしますか？", vbYesNo + vbQuestion)
    If Not rc = vbYes Then Exit Sub
  End If
  
  Select Case target.Column
    'A列
    Case 1
      If target.Offset(-1, 0).Value = "" Or target.Offset(-1, 1).Value = "" Then Exit Sub    
      target.Value = Now()
      If Not IsUserform1Loaded Then Load UserForm1
      Set UserForm1.target = target
      UserForm1.Show vbModeless
    'B列
    Case 2
      If target.Offset(0, -1).Value = "" Then Exit Sub
      With target
        .Value = Now()
        .Offset(0, 2).Value = (.Value - .Offset(0, -1).Value) * 24 * 60
        .Offset(0, 2).Style = "Comma [0]"
        .Offset(1, -1).Activate
      End With
      ActiveCell.Value = Now()
      If Not IsUserform1Loaded Then Load UserForm1
      Set UserForm1.target = target.Offset(1, -1)
      UserForm1.Show vbModeless
    Case Else
  
  End Select
  
End Sub

Private Sub Worksheet_Change(ByVal target As Range)
  If target.Cells.Count > 1 Then Exit Sub
  If target.Column > 2 Then Exit Sub
  With target
    Select Case .Column
      Case 1
        If .Offset(, 1).Value = "" Or .Value = "" Then Exit Sub
         .Offset(, 3).Value = (.Offset(0, 1).Value - .Value) * 24 * 60
      Case 2
        If .Offset(, -1).Value = "" Or .Value = "" Then Exit Sub
         .Offset(, 2).Value = (.Value - .Offset(0, -1).Value) * 24 * 60
    End Select
  End With
End Sub

'作業入力用フォームを表示した状態で、C列をクリックすると
Private Sub Worksheet_SelectionChange(ByVal target As Range)
  Dim myRange As Range
  
  Select Case target.Column
    Case 3
      If Not IsUserform1Loaded Then Exit Sub
      If UserForm1.Visible = False Then Exit Sub
      If Not UserForm1.target Is Nothing Then
        Set myRange = UserForm1.target
      End If
      If IsUserform2Loaded Then Unload UserForm2
      If target.Value <> "" Then
        Unload UserForm1
      Else
        Exit Sub
      End If      
      If target.Value <> "" Then myRange.Offset(0, 2).Value = target.Value
    Case Else
      Exit Sub
  End Select
End Sub

Function IsUserform1Loaded() As Boolean
  Dim f As UserForm
  
  For Each f In UserForms
    If TypeOf f Is UserForm1 Then
      IsUserform1Loaded = True
    End If
  Next f
End Function

Function IsUserform2Loaded() As Boolean
  Dim f As UserForm
  
  For Each f In UserForms
    If TypeOf f Is UserForm2 Then
      IsUserform2Loaded = True
    End If
  Next f
End Function

'☆ThisWorkbook
 
'計算のやり直しをさせているがその後のシートのイベント群の改造によりあまり意味は無いかも
Private Sub Workbook_Open()
  Dim targetRange As Range
  Dim myFindRange As Range
  Const targetColumn As Long = 4 'D列
  
  With ThisWorkbook.Sheets("Sheet1")
    On Error Resume Next
    Set myFindRange = .Columns(targetColumn).Find("*", Columns(targetColumn).Cells(1), xlFormulas, xlWhole, xlBy
Columns, xlPrevious)
    On Error GoTo 0
    If myFindRange Is Nothing Then Exit Sub 'D列空
    
    Set targetRange = .Range(.Cells(1, targetColumn), myFindRange)
    Set targetRange = Intersect(targetRange, targetRange.Offset(1, 0))
    If targetRange Is Nothing Then Exit Sub 'Data無し
    targetRange.FormulaR1C1 = "=(RC[-2]-RC[-3])*24*60"
    targetRange.Value = targetRange.Value
  End With
End Sub

'☆UserForm1
 
'******************************************
'TextBox一個と、Spinbutton一個を置く
'******************************************
Private myTarget As Range
Private CtrlFlag As Boolean

'呼び元のセルを保持
Public Property Set target(newRange As Range)
  If newRange.Cells.Count = 1 Then Set myTarget = newRange
End Property

Public Property Get target() As Range
  If Not myTarget Is Nothing Then Set target = myTarget
End Property

'SpinButton
Private Sub SpinButton1_SpinDown()
  ActiveWindow.SmallScroll Down:=10
End Sub

Private Sub SpinButton1_SpinUp()
  ActiveWindow.SmallScroll Up:=10
End Sub

'TextBox
'Ctrlとfのキーを同時に押している事の検出方法が分からないため、
'KeyDownとKeyUpの併用で模擬している
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  Const myCtrlMask As Integer = 2
  
  'vbCtrlとかで十分な気もするのだが...
  If (Shift And myCtrlMask) > 0 Then
    CtrlFlag = True
    Me.TextBox1.IMEMode = fmIMEModeOff
    Exit Sub
  End If
  
  If KeyCode = vbKeyReturn Then
    If Not myTarget Is Nothing Then
      If Me.TextBox1.Value <> "" Then
        myTarget.Offset(0, 2).Value = Me.TextBox1.Value
      End If
    Else
      MsgBox "UserForm1の初期化エラーです"
    End If
    Unload Me
  End If
End Sub

'Ctrl + f に対応するコード
Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  If CtrlFlag And KeyCode = vbKeyF Then
    Me.TextBox1.Value = ""
    CtrlFlag = False
    Me.TextBox1.IMEMode = fmIMEModeOn
    UserForm2.Show vbModeless
  End If
End Sub

Private Sub UserForm_Initialize()
  Dim pox#, poy#
  Const spinButtonWidth As Long = 12
  
  On Error GoTo errHandle
  Me.Caption = "Input Task : Ctrl + f で検索"
  Me.Width = 260
  Me.Height = 44
  With Me.TextBox1
    .Top = 0
    .Left = 0
    .Width = Me.InsideWidth - spinButtonWidth
    .Height = Me.InsideHeight
  End With
  With Me.SpinButton1
    .Top = 0
    .Left = Me.TextBox1.Width + 1
    .Height = Me.InsideHeight
    .Width = spinButtonWidth
  End With
  If ActiveCell.Column <> 1 Then
    MsgBox "Error! ActiveCell: " & ActiveCell.Address
    Err.Raise 9999, , "ActiveCell異常"
  End If
  
  'k窓のkPosCell関数利用　本体は標準モジュールに記述
  'http://www2.aqua-r.tepm.jp/~kmado/ke13u009.html
  If kPosCell(Me, pox, poy) = -1 Then Exit Sub
  StartUpPosition = 0
  Left = pox
  Top = poy
  
errHandle:
  If Err.Number <> 0 Then
    MsgBox "異常終了します " & Err.Number & ":" & Err.Description
    Unload Me
  End If
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  'フォームの×ボタンで閉じられた時は処理終了と判断してA列のデータ消去
  If CloseMode = vbFormControlMenu Then myTarget.Value = ""
End Sub
Private Sub UserForm_Terminate()
  ActiveWorkbook.Save
  myTarget.Parent.Activate
  myTarget.Activate
  
  If myTarget.Row > 10 Then
    Application.Goto myTarget.Offset(-10, 0), Scroll:=True
    myTarget.Activate
  Else
    Application.Goto myTarget.Offset(-1 * (myTarget.Row - 1), 0), Scroll:=True
  End If
  ActiveWindow.WindowState = xlMinimized
End Sub

'☆UserForm2
 
'******************************************
'TextBox一個と、
'CheckBox三個
'　大文字と小文字を区別する , 完全に同一なセルだけを検索, 半角と全角を区別する
'CommandButton三個
'　検索 , 次を検索, 閉じる
'を置く。検索ダイアログを模擬。
'******************************************
Dim targetRange As Range
Dim findRange As Range
Dim jumpCell As Range
Dim previousCell As Range

Private Sub findButton_Click()
  findSub
End Sub

Private Sub findNextButton_Click()
  On Error Resume Next
  
  If findRange Is Nothing Then Exit Sub
  Set findRange = targetRange.FindNext(findRange)
  On Error GoTo 0
  If findRange Is Nothing Or previousCell.Address = findRange.Address Then
    MsgBox "見つかりませんでした"
    Exit Sub
    Application.EnableEvents = True
  Else
    Set jumpCell = findRange.Offset(, -2)
    jumpCell.Activate
    Application.Goto jumpCell, Scroll:=True
    Set previousCell = findRange
  End If
  Application.EnableEvents = True
End Sub

Private Sub exitButton_Click()
  Unload Me
End Sub

Sub findSub()
  On Error Resume Next
  
  Application.EnableEvents = False
  Set findRange = targetRange.Find( _
    What:=Me.TextBox1.Value, _
    After:=targetRange.Cells(1), _
    LookIn:=xlValues, _
    LookAt:=IIf(Me.wholeCheck.Value, xlWhole, xlPart), _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlNext, _
    MatchCase:=IIf(Me.UcaseCheck.Value, True, False), _
    MatchByte:=IIf(Me.ignoreWideCheck.Value, True, False))
  On Error GoTo 0
  If findRange Is Nothing Then
    MsgBox "見つかりませんでした"
    Application.EnableEvents = True
    Exit Sub
  Else
    Set jumpCell = findRange.Offset(, -2)
    jumpCell.Activate
    Application.Goto jumpCell, Scroll:=True
    Set previousCell = findRange
  End If
  Application.EnableEvents = True
End Sub

Private Sub TextBox1_AfterUpdate()
  findSub
End Sub

Private Sub UserForm_Initialize()
  Set targetRange = Sheets("Sheet1").Range("$C:$C")
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  '念のため
  Application.EnableEvents = True
End Sub

'☆Module1
'ActiveCellの隣にUserformを表示させるための関数です 

'セルのスクリーン座標を取得します ポイント単位
'引数 uf ユーザーフォーム
'     psx,poy セル座標、pos セル位置(既定値はActiveCellの右下)
'     kx,ky ポイント・ピクセル変換係数
'戻り値 0=成功 -1→未対応
Function kPosCell(uf As Object, ByRef pox#, ByRef poy#, Optional pos As Range, _
  Optional ByRef kx#, Optional ByRef ky#) As Long
  '出典
  'http://www2.aqua-r.tepm.jp/~kmado/ke13u009.html
  'kPosCell関数
  '中味は載せるのを憚りますので、リンク先をご参照下さい。
  'なお、先頭行固定程度なら、下記はコメントアウトしても良さそうです。
  'If ActiveWindow.Panes.Count > 1 Then kPosCell = -1: Exit Function
  
  'コード略

End Function
UserFormのTextBoxでショートカットキーを実現
