Excel VBA質問箱 IV

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

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


14593 / 76734 ←次へ | 前へ→

【67630】Re:1つの条件で表示
回答  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
0 hits

【67604】1つの条件で表示 miyama 10/12/17(金) 14:39 質問
【67606】Re:1つの条件で表示 Jaka 10/12/17(金) 15:19 発言
【67607】Re:1つの条件で表示 UO3 10/12/17(金) 15:47 回答
【67616】Re:1つの条件で表示 miyama 10/12/18(土) 11:41 発言
【67619】Re:1つの条件で表示 UO3 10/12/18(土) 15:52 回答
【67611】Re:1つの条件で表示 kanabun 10/12/18(土) 0:23 発言
【67617】Re:1つの条件で表示 miyama 10/12/18(土) 11:51 発言
【67618】Re:1つの条件で表示 こたつねこ 10/12/18(土) 14:30 回答
【67630】Re:1つの条件で表示 Hirofumi 10/12/19(日) 18:33 回答
【68005】Re:1つの条件で表示 miyama 11/1/25(火) 9:44 お礼

14593 / 76734 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free