Excel VBA質問箱 IV

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

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


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

【64118】駐車場の車両チェック 駐車場監視員 10/1/20(水) 15:28 質問[未読]
【64120】Re:駐車場の車両チェック 超初心者 10/1/20(水) 18:01 発言[未読]
【64121】Re:駐車場の車両チェック UO3 10/1/20(水) 18:19 回答[未読]
【64123】Re:駐車場の車両チェック たつや 10/1/20(水) 20:19 発言[未読]
【64124】Re:駐車場の車両チェック Hirofumi 10/1/20(水) 20:21 回答[未読]
【64125】Re:駐車場の車両チェック 駐車場監視員 10/1/20(水) 20:33 お礼[未読]

【64118】駐車場の車両チェック
質問  駐車場監視員  - 10/1/20(水) 15:28 -

引用なし
パスワード
   お世話になります。駐車場監視員です。

ある月極駐車場に無契約で駐車している車両を記録し、連続で駐車している
車両の持ち主に駐車料を請求することになり、データを整理しています。

データは次の通りで、駐車可能台数は300台です。

日付 車両ナンバー 
1/1  あ1234 い2345 う3456 く3456 お5678
1/2  か1234 き2345 い2345 う3456
1/3  か1234 い2345 く3456 え4567 あ1234
1/4  あ1234 く3456 か1234
:
:

例えば上の例で3日以上連続駐車のチェックだと、
い2345、か1234
の2つの車両が引っかかります。

ある列に入力する車両を同じ車両にすればデータの集計で
出来ますが、そのように入力するのは大変で現実的ではありません。
しかし、データ数が日によって変わり、同じデータを入力する列も
バラバラだとお手上げでどうしていいか分かりません。

エキスパートの先輩方、なにとぞご教示下さいませ。

【64120】Re:駐車場の車両チェック
発言  超初心者  - 10/1/20(水) 18:01 -

引用なし
パスワード
   ▼駐車場監視員 さん:
エキスパートではありませんが・・・m(_~_)m

こんな形でデータ記録してはいかがでしょう。

日付 車両ナンバー 
1/1 あ1234 
1/1 い2345 
1/1 う3456
1/1 く3456 
1/1 お5678
1/2 か1234 
1/2 き2345 
1/2 い2345
1/2 う3456
1/3 か1234 
1/3 い2345 
1/3 く3456
1/3 え4567 
1/3 あ1234
1/4 あ1234 
1/4 く3456 
1/4 か1234

ピボットテーブルで変形(?)などすれば、
連続駐車のチェックも簡単かも!?

【64121】Re:駐車場の車両チェック
回答  UO3  - 10/1/20(水) 18:19 -

引用なし
パスワード
   ▼駐車場監視員 さん:

 どんなロジックで処理するにせよ、超初心者さんご提示のレイアウト
 がいいと思います。どうしても今の書式は変えられないということであれば
 VBAでシートを追加して、そこに既存のシートからデータを移し、ソートを
 かけた上で処理、処理後、追加したシートを削除、あるいはデータブックを
 保存なしでクローズという方式でしょうか。

【64123】Re:駐車場の車両チェック
発言  たつや  - 10/1/20(水) 20:19 -

引用なし
パスワード
   素朴な疑問ですが、無契約で駐車している車がそんなにあるのでしょうか?
また、3日連続ではなく、超初心者さんのおっしゃっているように、単純にピボットテーブルで発見回数を合計するだけではだめでしょうか。

もちろんVBAでやれないことはないと思いますが、エラーへの対処(たとえば同じデータを2回入力してしまった場合、半角と全角が混ざっている場合など)を考えると、一日10台×365日程度であれば、目視で確認したほうがはるかに速いように思います。

どうしてもVBAでやりたいのであれば、具体的にどのような形式でデータを出力したいのかを先に考えるべきでしょうね。

【64124】Re:駐車場の車両チェック
回答  Hirofumi  - 10/1/20(水) 20:21 -

引用なし
パスワード
   データ的にはそんなに多く無いのでしょうから?
別なシートに集計表を作ったら?
元のデータは、Sheet1に在るとします、先頭行は列見出しとします
結果はSheet2に出力されます

Option Explicit

Public Sub Sample()

  Dim i As Long
  Dim j As Long
  Dim lngRows As Long
  Dim lngColumn As Long
  Dim lngColumns As Long
  Dim rngResult As Range
  Dim vntResult As Variant
  Dim vntData As Variant
  Dim lngMax As Long
  Dim lngMin As Long
  Dim dicIndex As Object
  Dim lngTop As Long
  Dim lngCount As Long
  Dim strProm As String

  '結果出力の先頭セル位置を基準とする(先頭列の列見出しのセル位置)
  Set rngResult = Worksheets("Sheet2").Cells(1, "A")
  
  'Dictionaryオブジェクトを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  
  With Worksheets("Sheet1").UsedRange
    '日付の最小値、最大値を取得
    lngMin = Application.WorksheetFunction.Min(.Resize(, 1))
    lngMax = Application.WorksheetFunction.Max(.Resize(, 1))
    '行数、列数を取得
    lngRows = .Rows.Count
    lngColumns = .Columns.Count
    '結果用配列を確保
    ReDim vntResult(lngMax - lngMin + 1, 0)
    '配列の0列目に日付を記入
    For i = 1 To lngMax - lngMin + 1
      vntResult(i, 0) = i + lngMin - 1
    Next i
    'Listのデータ先頭〜最終まで繰り返し
    For i = 2 To lngRows
      'Listから1行分配列に取得
      vntData = .Cells(i, 1).Resize(, lngColumns).Value
      '配列の2列目〜最終列まで繰り返し
      For j = 2 To lngColumns
        '値がEmptyならForを脱出
        If IsEmpty(vntData(1, j)) Then
          Exit For
        End If
        'Dictionaryに登録が無い場合
        If Not dicIndex.Exists(vntData(1, j)) Then
          '登録番号を発番
          lngColumn = lngColumn + 1
          'Dictionaryにナンバーを登録
          dicIndex.Item(vntData(1, j)) = lngColumn
          '結果配列を拡張して、発番した列位置の
          '先頭行にナンバーをを書き込み
          ReDim Preserve vntResult(lngMax - lngMin + 1, lngColumn)
          vntResult(0, lngColumn) = vntData(1, j)
        End If
        '配列の日付行の該当番号位置に"*"を書き込み
        vntResult(CLng(vntData(1, 1)) - lngMin + 1, _
              dicIndex.Item(vntData(1, j))) = "*"
      Next j
    Next i
  End With
 
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '結果を出力
  With rngResult
    .Parent.Cells.ClearContents
    '日付書式を設定
    .Resize(, UBound(vntResult, 1) + 1).NumberFormat = "m/d"
    '結果を出力
    .Resize(UBound(vntResult, 2) + 1, UBound(vntResult, 1) + 1).Value _
        = Application.Transpose(vntResult)
    '連続して三日以上の場合、BuckColorを変更
    For i = 1 To UBound(vntResult, 2)
      lngTop = 0
      lngCount = 0
      For j = 1 To UBound(vntResult, 1)
        If vntResult(j, i) <> "" Then
          If lngTop = 0 Then
            lngTop = j
            lngCount = 1
          Else
            lngCount = lngCount + 1
          End If
        Else
          If lngCount >= 3 Then
            .Offset(i, lngTop).Resize(, lngCount).Interior.ColorIndex = 34
          End If
          lngTop = 0
          lngCount = 1
        End If
      Next j
      If lngCount >= 3 Then
        .Offset(i, lngTop).Resize(, lngCount).Interior.ColorIndex = 34
      End If
    Next i
    .Parent.Columns.AutoFit
  End With
    
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set dicIndex = Nothing
  Set rngResult = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

【64125】Re:駐車場の車両チェック
お礼  駐車場監視員  - 10/1/20(水) 20:33 -

引用なし
パスワード
   >Hirofumi様
詳細なコードを提示していただき、大変恐縮です。やや難解ですが、
一つ一つ解読していこうと思います。

他の回答者の皆様も、アドバイス頂き大変有り難いです。
超初心者様のデータの並べ方は気がつきませんでした・・・。

皆様のアドバイスを参考に頑張ってみます。
ど素人の質問にご回答いただき、有り難うございました。

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