Excel VBA質問箱 IV

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

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


64397 / 76732 ←次へ | 前へ→

【16916】Re:検索関数について教えてください。
回答  Hirofumi  - 04/8/16(月) 13:24 -

引用なし
パスワード
   Dictionaryオブジェクトが使えるならこちらの方が早いかも?

Option Explicit

Public Sub AddUp2()

  Dim i As Long
  Dim j As Long
  Dim lngRow As Long
  Dim lngCol As Long
  Dim dicRowIndex As Object
  Dim dicColIndex As Object
  Dim vntData As Variant
  Dim vntResult As Variant
  Dim vntItem() As Variant
  
  'デ−タの有るシートのデータを配列に取得
  'デ−タの左上隅のセルを設定
  If Not GetData(vntData, _
      Worksheets("Sheet1").Cells(1, "A")) Then
    Beep
    MsgBox "データが有りません"
    Exit Sub
  End If
  
  '列Indexのオブジェクト変数dicColIndexに
  'Dictionaryのインスタンスを取得
  Set dicColIndex = CreateObject("Scripting.Dictionary")
  '行Indexのオブジェクト変数dicColIndexに
  'Dictionaryのインスタンスを取得
  Set dicRowIndex = CreateObject("Scripting.Dictionary")
  
  '番号(行)のIndexを作成
  With dicRowIndex
    j = 1
    '配列の最終行まで繰り返す
    For i = 1 To UBound(vntData, 1)
      '番号(行)のIndexにKeyが無い場合
      If Not .Exists(vntData(i, 1)) Then
        'Key(番号)、項目(vntResultの行位置)を追加
        .Add vntData(i, 1), j
        '重複なしの番号を取得
        ReDim Preserve vntItem(1 To j)
        vntItem(j) = vntData(i, 1)
        '行位置を更新
        j = j + 1
      End If
    Next i
  End With
  
  '結果用配列を確保
  ReDim vntResult(UBound(vntItem, 1), 0)
  '番号を結果用配列に転記
  For i = 1 To UBound(vntItem, 1)
    vntResult(i, 0) = vntItem(i)
  Next i
  '番号を保持する配列を破棄
  Erase vntItem
  
  '結果用配列に室名、データを転記
  With dicColIndex
    j = 1
    For i = 1 To UBound(vntData, 1)
      '日付のIndexに日付が有った時
      If .Exists(vntData(i, 2)) Then
        '結果配列の列位置を取得
        lngCol = .Item(vntData(i, 2))
      Else
        '日付のIndexに日付、列位置を追加
        .Add vntData(i, 2), j
        '結果配列の列を配列の値を保持したまま拡張
        ReDim Preserve vntResult(UBound(vntResult, 1), j)
        '結果配列の拡張位置に日付を代入
        vntResult(0, j) = vntData(i, 2)
        '結果配列の列位置を設定
        lngCol = j
        '結果配列の添え字の最大値を更新
        j = j + 1
      End If
      '結果用配列の行位置を取得
      lngRow = dicRowIndex.Item(vntData(i, 1))
      '結果配列の拡張位置に値を積算
      vntResult(lngRow, lngCol) _
          = vntResult(lngRow, lngCol) + 1
    Next i
  End With
  
  Set dicColIndex = Nothing
  Set dicRowIndex = Nothing
  
  Application.ScreenUpdating = False
  
  '結果用配列をSheet2に出力
  With Worksheets("Sheet2")
    .Cells.Clear
    lngRow = UBound(vntResult, 1) + 1
    lngCol = UBound(vntResult, 2) + 1
    '結果表の左上隅に就いて
    With .Cells(1, "A")
      With .Resize(lngRow, lngCol)
        '結果出力
        .Value = vntResult
        '行を番号順にソート
        .Sort Key1:=.Item(1), Order1:=xlAscending, _
            Header:=xlYes, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom, _
            SortMethod:=xlStroke
      End With
      With .Offset(, 1).Resize(, lngCol - 1)
        '書式を日付に設定
        .NumberFormat = "yyyy/mm/dd"
        '列を日付昇順にソート
        With .Resize(lngRow)
          .Sort Key1:=.Item(1), Order1:=xlAscending, _
              Header:=xlNo, OrderCustom:=1, _
              MatchCase:=False, Orientation:=xlLeftToRight, _
              SortMethod:=xlStroke
        End With
      End With
    End With
  End With
  
  Application.ScreenUpdating = True
  
  Beep
  MsgBox "処理が完了しました"
  
End Sub

Private Function GetData(vntData As Variant, _
            rngDataTop As Range) As Boolean
  
  Dim rngScope As Range
  
  Set rngScope = rngDataTop.CurrentRegion
  
  With rngScope
    'もし、データが有る場合
    If .Columns.Count >= 1 And .Rows.Count >= 1 Then
      'wksDataのデータを配列に取得
      vntData = .Value
      'データ取得成功を戻す
      GetData = True
    End If
  End With
  
  Set rngScope = Nothing
  
End Function
0 hits

【16903】検索関数について教えてください。 お初 04/8/15(日) 17:47 質問
【16904】Re:検索関数について教えてください。 ichinose 04/8/15(日) 19:22 回答
【16905】Re:検索関数について教えてください。 Hirofumi 04/8/15(日) 20:26 回答
【16916】Re:検索関数について教えてください。 Hirofumi 04/8/16(月) 13:24 回答
【16940】Re:検索関数について教えてください。 お初 04/8/16(月) 19:38 お礼

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