| |
▼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さんの関数の方で
行いました。
ＶＢＡが分かるようになるまではもう少し時間がかかりそうなので、
そのときはHirofumiさんのコードを参考にさせていただきます。
どうもありがとうございました。
|
|
お初
- 04/8/16(月) 19:38 -
