Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

14593 / 76734

←次へ　｜　前へ→


	【67630】Re:１つの条件で表示

Hirofumi - 10/12/19(日) 18:33 -


	引用なし

	パスワード

面白そうなので、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

2 hits

▼

【67604】１つの条件で表示 miyama 10/12/17(金) 14:39