| |
>つまり、抽出した表のX,Y軸の項目は決まってまして、元データは
>その項目がランダムに入力されます 項目の無いものは入力されません
「項目の無いものは入力されません」と言うのが、「項目の無い物は、カウントしません」
の意味なら、以下の様でも善いかも？（余り速く無いけど？）
Option Explicit
Public Sub Sample()
Dim i As Long
Dim lngRows As Long
Dim lngRow As Long
Dim lngColumn As Long
Dim rngList As Range
Dim vntData As Variant
Dim rngResult As Range
Dim vntResult As Variant
Dim vntRows As Variant
Dim vntColumns As Variant
Dim strProm As String
'Sheet1のListの左上隅セル位置を基準として設定
Set rngList = Worksheets("Sheet1").Cells(1, "A")
With rngList
'データ行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
'データが無い場合
If lngRows <= 1 And .Value = "" Then
strProm = "データが有りません"
GoTo Wayout
End If
'データを配列に取得
vntData = .Resize(lngRows, 2).Value
End With
'Sheet2Listの左上隅セル位置を基準として設定(見出しの「a」の左、「い」の上のセル位置)
Set rngResult = Worksheets("Sheet2").Cells(1, "A")
With rngResult
'行見出しの行数を取得
lngRow = .Offset(65536 - .Row).End(xlUp).Row - .Row
'データが有る場合
If lngRow > 0 Then
vntRows = .Offset(1).Resize(lngRow + 1).Value
End If
'列見出しの列数を取得
lngColumn = .Offset(, 256 - .Column).End(xlToLeft).Column - .Column
'データが有る場合
If lngColumn > 0 Then
vntColumns = .Offset(, 1).Resize(, lngColumn + 1).Value
End If
'結果出力用配列を確保
ReDim vntResult(1 To lngRow, 1 To lngColumn)
End With
'カウントを集計
For i = 1 To lngRows
'A列の値をListの行見出しから探索する
lngRow = GetRowPos(vntData(i, 1), vntRows)
'値が合った場合
If lngRow > 0 Then
'B列の値をListの列見出しから探索する
lngColumn = GetColumnPos(vntData(i, 2), vntColumns)
'値が合った場合
If lngColumn > 0 Then
'結果配列にカウントする
vntResult(lngRow, lngColumn) _
= vntResult(lngRow, lngColumn) + 1
End If
End If
Next i
'画面更新を停止
Application.ScreenUpdating = False
'結果を出力
rngResult.Offset(1, 1).Resize(UBound(vntResult, 1), _
UBound(vntResult, 2)).Value = vntResult
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function GetRowPos(vntKey As Variant, vntScope As Variant) As Long
Dim i As Long
Dim lngListEnd As Long
'行見出しが無い場合
If VarType(vntScope) = vbVariant Then
Exit Function
End If
'行見出しの行数を取得
lngListEnd = UBound(vntScope, 1) - 1
For i = 1 To lngListEnd
'もし、行見出しと探索Keyが合致したら戻り値として行位置を返す
If StrComp(vntKey, vntScope(i, 1), vbTextCompare) = 0 Then
GetRowPos = i
Exit Function
End If
Next i
End Function
Private Function GetColumnPos(vntKey As Variant, vntScope As Variant) As Long
Dim i As Long
Dim lngListEnd As Long
If VarType(vntScope) = vbVariant Then
Exit Function
End If
lngListEnd = UBound(vntScope, 2) - 1
For i = 1 To lngListEnd
If StrComp(vntKey, vntScope(1, i), vbTextCompare) = 0 Then
GetColumnPos = i
Exit Function
End If
Next i
End Function
|
|
Hirofumi
- 06/2/12(日) 13:03 -
