| |
UserFormにTextBoxが3個、CommandButtonが1個有るとします
TextBox1：日付入力
TextBox2：車体番号入力
TextBox3：燃料量入力
車体番号、日付共に昇順整列が必須とします
合計は各日付の上に代入されます
尚、燃料の量と合計は、CommandButton1を押した事にに拠り、出力、計算がされます
Option Explicit
'日付の先頭位置の前の列(「車体番号」を基準として「日付」の列Offset値）
Const clngTop As Long = 0
'出力シートの基準位置
Private rngResult As Range
'日付範囲
Private rngDate As Range
'車体番号範囲
Private rngScope As Range
Private Sub CommandButton1_Click()
Dim i As Long
Dim lngColumn As Long
Dim lngRow As Long
Dim vntData As Variant
Dim vntSum As Variant
lngColumn = CLng(TextBox1.Tag)
'日付が選択されていない場合
If TextBox1.Tag = 0 Then
Exit Sub
End If
lngRow = CLng(TextBox2.Tag)
'車体番号が選択されていない場合
If lngRow = 0 Then
Exit Sub
End If
'日付、車体番号の交差するセルに値を書き込み
With rngResult.Offset(, clngTop)
.Offset(lngRow, lngColumn).NumberFormatLocal = "G/標準"
.Offset(lngRow, lngColumn).Value = Val(TextBox3.Text)
End With
With rngResult.Offset(, clngTop)
'選択した日付の列の値を配列に取得
vntData = .Offset(1, lngColumn).Resize(rngScope.Count).Value
For i = 1 To UBound(vntData, 1)
vntSum = vntSum + Val(vntData(i, 1))
Next i
'合計を出力
.Offset(-1, lngColumn).Value = vntSum
End With
TextBox2.Text = ""
TextBox3.Text = ""
TextBox1.SetFocus
End Sub
Private Sub TextBox1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
' 日付列の探索と作成
Dim lngDate As Long
Dim lngFound As Long
With TextBox1
If .Value <> "" Then
If IsDate(.Value) Then
lngDate = DateValue(.Value)
'日付を探索
.Tag = GetDateColumn(lngDate, rngDate, _
rngResult.Offset(, clngTop))
Else
Beep
Cancel = True
End If
End If
End With
End Sub
Private Sub TextBox2_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
' 車体番号行の探索、作成
Dim lngFound As Long
With TextBox2
If .Value <> "" Then
'車体番号を探索
.Tag = GetIDNoRow(.Text, rngScope, rngResult)
End If
End With
End Sub
Private Sub TextBox3_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
With TextBox3
If .Value <> "" Then
'数値のチェック
If Not IsNumeric(.Text) Then
Beep
Cancel = True
End If
End If
End With
End Sub
Private Sub UserForm_Initialize()
'シート最終行
Const clngLastRow As Long = 65536
Dim lngColumn As Long
Dim lngRow As Long
'Sheet2出力表のA1セルを基準とする(列見出し「商品ID」のセル位置)
' Set rngResult = Worksheets("Sheet1").Cells(2, "A")
Set rngResult = Worksheets("Sheet3").Cells(2, "A")
With rngResult
'日付の書かれている列数を取得
lngColumn = .Offset(, 256 - .Column).End(xlToLeft).Column _
- .Offset(, clngTop).Column
'日付列の範囲を取得
If lngColumn > 0 Then
Set rngDate = .Offset(, clngTop + 1).Resize(, lngColumn)
End If
'IDが有る行数を取得
lngRow = .Offset(clngLastRow - .Row).End(xlUp).Row - .Row
'IDが有る範囲を取得
If lngRow > 0 Then
Set rngScope = .Offset(1).Resize(lngRow)
End If
End With
TextBox1.Tag = 0
TextBox2.Tag = 0
End Sub
Private Sub UserForm_Terminate()
Set rngResult = Nothing
Set rngScope = Nothing
Set rngDate = Nothing
End Sub
Private Function GetDateColumn(vntDate As Variant, _
rngScope As Range, _
rngDateTop As Range) As Long
Dim lngFound As Long
Dim lngOver As Long
Dim lngCount As Long
'日付範囲に日付が無いなら
If rngScope Is Nothing Then
lngFound = 0
lngCount = 0
lngOver = 1
Else
'日付の探索
'セル値が数値として入力されている場合
lngFound = DataSearch(CLng(vntDate), rngScope, lngOver)
'セル値が文字列として入力されている場合
' lngFound = DataSearch(vntDate, rngScope, lngOver)
lngCount = rngScope.Columns.Count
End If
'日付が見つかった場合
If lngFound > 0 Then
'位置を返す
GetDateColumn = lngFound
Else
If MsgBox("指定された日付が有りません、" & Format(vntDate, "yyyy/m/d") _
& "の列を作ります", vbInformation + vbOKCancel, "日付不一致") = vbOK Then
With rngDateTop
'日付が最終列の以内の場合
If lngOver <= lngCount Then
'指定位置に列を挿入
.Offset(, lngOver).EntireColumn.Insert
End If
'日付を書き込み
With .Offset(, lngOver)
.NumberFormatLocal = "yyyy/m/d"
.Value = vntDate
End With
'挿入位置を返す
GetDateColumn = lngOver
'日付列の範囲を更新
Set rngScope _
= .Offset(, 1).Resize(, lngCount + 1)
End With
End If
End If
End Function
Private Function GetIDNoRow(vntID As Variant, _
rngScope As Range, _
rngListTop As Range) As Long
Dim lngFound As Long
Dim lngOver As Long
Dim lngCount As Long
'車体番号範囲に車体番号が無いなら
If rngScope Is Nothing Then
lngFound = 0
lngCount = 0
lngOver = 1
Else
'車体番号を探索
lngFound = DataSearch(vntID, rngScope, lngOver)
lngCount = rngScope.Rows.Count
End If
'探索成功（車体番号が有るなら）
If lngFound > 0 Then
'位置を返す
GetIDNoRow = lngFound
Else
If MsgBox("車体番号が有りません、" & vntID & "の行を作ります", _
vbInformation + vbOKCancel, "番号不一致") = vbOK Then
With rngListTop
'挿入位置が行末で無いなら
If lngOver <= lngCount Then
'行を挿入
.Offset(lngOver).EntireRow.Insert
End If
'セルの書式を文字列に設定
.Offset(lngOver).NumberFormatLocal = "@"
'車体番号を書き込み
.Offset(lngOver).Value = vntID
'挿入位置を返す
GetIDNoRow = lngOver
'探索範囲の更新
Set rngScope _
= .Offset(1).Resize(lngCount + 1)
End With
End If
End If
End Function
Private Function DataSearch(vntKey As Variant, _
rngScope As Range, _
Optional lngOver As Long, _
Optional lngMode As Long = 1) As Long
Dim vntFind As Variant
'Matchによる二分探索
vntFind = Application.Match(vntKey, rngScope, lngMode)
lngOver = 1
'もし、エラーで無いなら
If Not IsError(vntFind) Then
'もし、Key値と探索位置の値が等しいなら
If vntKey = rngScope(vntFind).Value Then
'戻り値として、行位置を代入
DataSearch = vntFind
End If
'Key値を超える最小値のある行
lngOver = vntFind + 1
End If
End Function
|
|
Hirofumi
- 06/1/2(月) 23:15 -
