| |
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
|
|
Hirofumi
- 04/8/16(月) 13:24 -
