Excel VBA質問箱 IV

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

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


64379 / 76738 ←次へ | 前へ→

【16940】Re:検索関数について教えてください。
お礼  お初  - 04/8/16(月) 19:38 -

引用なし
パスワード
   ▼Hirofumi さん:
>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

ichinoseさん、Hirofumiさん
どうもありがとうございます。
できました。

私は初心者なので、ichinoseさんの関数の方で
行いました。
VBAが分かるようになるまではもう少し時間がかかりそうなので、
そのときはHirofumiさんのコードを参考にさせていただきます。

どうもありがとうございました。

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

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