Excel VBA質問箱 IV

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

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


18052 / 76732 ←次へ | 前へ→

【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
1 hits

【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 お礼

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