Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


8450 / 13644 ツリー ←次へ | 前へ→

【33099】超初心者で何もわかりません。 あきこ 06/1/2(月) 21:22 質問[未読]
【33100】Re:縦に番号、横に日付の表に一致するセル... かみちゃん 06/1/2(月) 21:38 回答[未読]
【33101】Re:超初心者で何もわかりません。 Hirofumi 06/1/2(月) 23:15 回答[未読]
【33103】Re:超初心者で何もわかりません。 Hirofumi 06/1/2(月) 23:54 回答[未読]
【33248】Re:超初心者で何もわかりません。 あきこ 06/1/5(木) 20:33 お礼[未読]

【33099】超初心者で何もわかりません。
質問  あきこ  - 06/1/2(月) 21:22 -

引用なし
パスワード
   会社で車の燃料の集計をしています。
今までVBAの事を知らずにEXELでずっと手入力をしていました。
VBAを使えばできると聞いたのですが、本、過去ログを読んでもわからないので
質問させてください。
ユーザーフォームにTEXTBOXを1から3までと、コマンドボタン1を
つくり、TEXTBOXに入力した数値をSheet1に反映したいのですが、
やり方がさっぱりわかりません。
Sheet1には、横方向に日付けがあり、縦方向に車の番号が入っています(約100台)。TEXTBOX1には日付けのみの入力、TEXTBOX2には車の番号、TEXTBOX3には
使った燃料を入力して、TEXTBOX1に入力した時点で、該当する日付けの列だけ
アクティブにして、TEXTBOX2に入力したときに該当する車の番号のセルをアクティブにし、TEXTBOX3に入力すると内容がそのセルに反映され、最後にコマンドボタンを押すとその日の使用燃料のトータルを表示する。とゆうようなプログラムは可能でしょうか?超初心者でユーザーフォームを作るのがやっとです。ヒントだけでも
教えていただけたら幸いです。よろしくおねがいします。

【33100】Re:縦に番号、横に日付の表に一致するセ...
回答  かみちゃん E-MAIL  - 06/1/2(月) 21:38 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>Sheet1には、横方向に日付けがあり、縦方向に車の番号が入っています(約100台)。TEXTBOX1には日付けのみの入力、TEXTBOX2には車の番号、TEXTBOX3には
>使った燃料を入力して、TEXTBOX1に入力した時点で、該当する日付けの列だけ
>アクティブにして、TEXTBOX2に入力したときに該当する車の番号のセルをアクティブにし、TEXTBOX3に入力すると内容がそのセルに反映され、最後にコマンドボタンを押すとその日の使用燃料のトータルを表示する。

同様の集計作業を仕事でしていますが、コマンドボタンを押したら入力ではなく、
TextBox3に入力したら自動入力するのですか?
まずは、コマンドボタンを押したら、TextBox1の日付の検索と、TextBox2の車番の
検索をして、TextBox3の使用燃料を書き込む列と行の位置を決めることからしませんか?

以下は、そのコードです。
こちらでサンプルファイルを作ってみて、Excel2002 SP3 で動作確認済みです。

Private Sub CommandButton1_Click()
 Dim MatchC As Integer
 Dim MatchR As Integer
  
 MatchC = 0
 On Error Resume Next
 '日付の検索
 MatchC = Application.Match(CLng(DateValue(Me.TextBox1.Value)), Rows(1).Cells, 0)
 '車番の検索
 MatchR = Application.Match(Me.TextBox2.Value, Columns(1).Cells, 0)
 On Error GoTo 0
 If MatchC <> 0 And MatchR <> 0 Then
  Cells(MatchR, MatchC).Value = Me.TextBox3.Value
 Else
  MsgBox "日付または車番が存在しません"
 End If
End Sub

なお、エラー処理は、ほとんどしていません。
TextBox1の日付は、1/2や2005/1/2などと入力してください。

【33101】Re:超初心者で何もわかりません。
回答  Hirofumi  - 06/1/2(月) 23:15 -

引用なし
パスワード
   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

【33103】Re:超初心者で何もわかりません。
回答  Hirofumi  - 06/1/2(月) 23:54 -

引用なし
パスワード
   書き忘れましたが
コードは、UserFormのコードモジュールに記述して下さい
また、車体の番号が、数値ならコードの以下の部分を修正して下さい
「Private Function GetIDNoRow」の中で

  Else
    '車体番号を探索
'    lngFound = DataSearch(vntID, rngScope, lngOver)
    '車体番号のセル値が数値として入力されている場合は以下の様に変更
    lngFound = DataSearch(CLng(vntID), rngScope, lngOver) '★数値の場合、上記をこの様にする
    lngCount = rngScope.Rows.Count
  End If

其れと

        'セルの書式を文字列に設定
'        .Offset(lngOver).NumberFormatLocal = "@" '★この行コメントアウト若しくは、削除
        '車体番号を書き込み
        .Offset(lngOver).Value = vntID


後、当方のテストをSheet3で行いましたので
「Private Sub UserForm_Initialize()」の中が以下の様に成っていますので
あきこさんが、出力するシートにシート名を変更して下さい

  'Sheet2出力表のA1セルを基準とする(列見出し「商品ID」のセル位置)
'  Set rngResult = Worksheets("Sheet1").Cells(2, "A")
  Set rngResult = Worksheets("Sheet3").Cells(2, "A")

【33248】Re:超初心者で何もわかりません。
お礼  あきこ  - 06/1/5(木) 20:33 -

引用なし
パスワード
   かみちゃんさん、hirofumiさん、返事が遅くなってごめんなさい。
今日、会社で試してみたらうまくいきました。
本当に本当にありがとうございました。
後は、自力でなんとか対応できそうです。
何からなにまで親切に教えていただいて、感謝です。
これを機会にVBAをもっと勉強していきたいとおもいます。
本当にありがとうございました。

8450 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free