| |
面白そうなので、Dictionaryを使わないで作って見ました
抽出する、シートのシートモジュールに記述して下さい
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim strPrompt As String
With Target
If .Address(False, False) <> "S6" Then
Exit Sub
End If
End With
Application.EnableEvents = False
strPrompt = Extraction(Worksheets("Sheet1").Range("A1"), _
Me.Range("a1"), Me.Range("S6").Value)
If strPrompt <> "" Then
MsgBox strPrompt, vbInformation
End If
Application.EnableEvents = True
End Sub
Private Function Extraction(rngList As Range, rngResult As Range, vntKey As Variant) As String
'Listのデータ列数（A列〜E列）
Const clngColumns1 As Long = 5
'Listの中の「企業名」と成る列位置(基準列からのB列の列Offset：1列目)
Const clngKey As Long = 1
'結果表の列数
Const clngColumns2 As Long = 3
Dim i As Long
Dim j As Long
Dim lngRows As Long
Dim vntData As Variant
Dim lngTop As Long
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row, clngKey).End(xlUp).Row - .Row
If lngRows <= 0 Then
Extraction = "データが有りません"
GoTo Wayout
End If
End With
'画面更新を停止
Application.ScreenUpdating = False
With rngResult
'ヘッダを出力
.Resize(, clngColumns2).Value _
= rngList.Offset(, clngKey + 1).Resize(, clngColumns2).Value
'抽出条件を出力
.Offset(, clngColumns2).Value = rngList.Offset(, clngKey).Value
.Offset(, clngColumns2 + 1).Value = rngList.Offset(, clngColumns1 - 1).Value
.Offset(1, clngColumns2).Value = "=""" & vntKey & """"
If Not IsEmpty(vntKey) Then
.Offset(1, clngColumns2 + 1).Value = ">0"
Else
.Offset(1, clngColumns2 + 1).Value = "="""""
End If
'AdvancedFilterを実行
rngList.Resize(lngRows + 1, clngColumns1).AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=.Offset(, clngColumns2).Resize(2, 2), _
CopyToRange:=.Resize(, clngColumns2), _
Unique:=False
'抽出条件を消去
.Offset(, clngColumns2).Resize(2, 2).ClearContents
'行数の取得
lngRows = .Offset(Rows.Count - .Row, clngKey).End(xlUp).Row - .Row
If lngRows <= 0 Then
If Not IsEmpty(vntKey) Then
Extraction = "抽出するレコードが有りません"
End If
GoTo Wayout
End If
'抽出データを商品昇順の型式昇順で整列
.Offset(1).Resize(lngRows + 1, clngColumns2).Sort _
Key1:=.Offset(1), Order1:=xlAscending, _
Key2:=.Offset(1, 1), Order2:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'データを配列に取得
vntData = .Offset(1).Resize(lngRows + 1, clngColumns2).Value
End With
lngTop = 1
'Key列に就いて繰り返し
For i = 2 To lngRows + 1
If vntData(lngTop, 1) = vntData(i, 1) _
And vntData(lngTop, 2) = vntData(i, 2) Then
vntData(lngTop, clngColumns2) _
= vntData(lngTop, clngColumns2) + vntData(i, clngColumns2)
Else
lngTop = lngTop + 1
For j = 1 To clngColumns2
vntData(lngTop, j) = vntData(i, j)
Next j
End If
Next i
'結果を出力
With rngResult
.Offset(1).Resize(lngRows, clngColumns2).ClearContents
.Offset(1).Resize(lngTop, clngColumns2).Value = vntData
End With
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
End Function
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 10/12/18(土) 11:41 -
