Excel VBA質問箱 IV

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

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


5809 / 13646 ツリー ←次へ | 前へ→

【48743】オートフィルターについて hiro 07/5/4(金) 15:12 質問[未読]
【48745】Re:オートフィルターについて かみちゃん 07/5/4(金) 17:10 発言[未読]
【48751】Re:オートフィルターについて かみちゃん 07/5/4(金) 18:38 発言[未読]
【48754】Re:オートフィルターについて hiro 07/5/4(金) 20:09 発言[未読]
【48755】Re:オートフィルターについて かみちゃん 07/5/4(金) 20:39 発言[未読]
【48760】Re:オートフィルターについて Hirofumi 07/5/5(土) 3:53 回答[未読]
【48761】Re:オートフィルターについて Hirofumi 07/5/5(土) 11:31 回答[未読]
【48762】Re:オートフィルターについて hiro 07/5/5(土) 22:16 発言[未読]
【48763】Re:オートフィルターについて Hirofumi 07/5/5(土) 23:37 回答[未読]
【48764】Re:オートフィルターについて Hirofumi 07/5/6(日) 1:23 回答[未読]
【48767】Re:オートフィルターについて Hirofumi 07/5/6(日) 18:37 回答[未読]
【48768】Re:オートフィルターについて hiro 07/5/6(日) 21:24 お礼[未読]

【48743】オートフィルターについて
質問  hiro  - 07/5/4(金) 15:12 -

引用なし
パスワード
   初心者です よろしくお願いいたします

シート1(List1)
日付    店舗    項目    1係    2係    3係
20070401    本店    売上    1    1    1
20070401    本店    差益    2    2    2
20070401    本店    在庫    3    3    3
20070401    支店A    売上    4    4    4
20070401    支店A    差益    5    5    5
20070401    支店A    在庫    6    6    6
20070401    支店B    売上    7    7    7
20070401    支店B    差益    8    8    8
20070401    支店B    在庫    9    9    9
20070402    本店    売上    1    1    1
20070402    本店    差益    2    2    2
20070402    本店    在庫    3    3    3
20070402    支店A    売上    4    4    4
20070402    支店A    差益    5    5    5
20070402    支店A    在庫    6    6    6
20070402    支店B    売上    7    7    7
20070402    支店B    差益    8    8    8
20070402    支店B    在庫    9    9    9

日々のデータをユーザーフォームから上記のように転記しております
これにオートフィルターで別シートに日にちと店舗を指定して抽出しております
これに売上と差益の累計値も同時に表示させたいと思っております

4月2日の本店を抽出するとシート2(List2)
本店    売上    1    1    1
本店    差益    2    2    2
本店    在庫    3    3    3
    売上    2    2    2
    差益    4    4    4
のように表示させたいのですがシート1(List1)に累計値がないとフィルターでは無理でしょうか?よろしくおねがいいたします
シート1のデータは3店舗×3項目で1日9行が1年分あります
係りは30係あります
現在のコードは下記のとおりです

Sub Test1()

  Dim sh1 As Worksheet
  Dim sh2 As Worksheet
  Set sh1 = Worksheets("List")  'リスト
  Set sh2 = Worksheets("List2")  '条件登録、結果表示

  Dim KeyA1 As String  '条件1
  Dim keyB1 As String   '条件2
  
 
  KeyA1 = sh2.Cells(2, 2).Value
  keyB1 = sh2.Cells(3, 2).Value
  

  '先回の結果をクリア (結果表示先List2シートA5:D20)
  sh2.Range(sh2.Cells(5, 1), sh2.Cells(20, 4)).ClearContents
  'オートフィルターで条件1、条件2を抽出
 
  With sh1
  '条件1
    .Cells(1, 1).AutoFilter Field:=1, Criteria1:=KeyA1
    
  '条件2
    .Cells(1, 1).AutoFilter Field:=2, Criteria1:=keyB1
    

  '抽出結果をコピーして結果表示場所に貼付け
    .AutoFilter.Range.Copy sh2.Cells(5, 1)
    .AutoFilterMode = False
  End With
End Sub

【48745】Re:オートフィルターについて
発言  かみちゃん E-MAIL  - 07/5/4(金) 17:10 -

引用なし
パスワード
   こんにちは。かみちゃん です。

> シート1(List1)に累計値がないとフィルターでは無理でしょうか?

フィルターだけでしようと思うと難しいと思います。
該当のデータを抽出して、累計値を後から計算して、付け足す感じにしないと
いけないのではないでしょうか?

あと、Accessをお持ちか、ADOなどは使えるでしょうか?
私なら、SQLで抽出する方法を考えますけど。

【48751】Re:オートフィルターについて
発言  かみちゃん E-MAIL  - 07/5/4(金) 18:38 -

引用なし
パスワード
   こんにちは。かみちゃん です。

> シート1(List1)に累計値がないとフィルターでは無理でしょうか?
>シート1のデータは3店舗×3項目で1日9行が1年分あります
>係りは30係あります

方法はいろいろあると思いますが、私なら、SQLを使って累計値を計算します。
ただ、初心者や、AccessやSQLをご存知でない場合は、少々難しいかもしれません。
こんなこともできるのね、という程度で参考にしていただければと思います。

こちらでは、サンプルデータで動作確認できています。
(ただし、3係分でテストしました。)

Sub Sample1()
 Dim cn As Object
 Dim link_opt As String
 Dim idx As Long
 Dim rs As Object
 Dim mysql As String
 Dim WS1 As Worksheet
 Dim WS2 As Worksheet
 Dim rng1 As Range
 
 Set WS1 = Sheets("Sheet1")
 Set WS2 = Sheets("Sheet2")
 Set rng1 = WS1.Range("A1").CurrentRegion
 
 'Excelデータベースに接続
 link_opt = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
      "Data Source=" & ThisWorkbook.FullName & ";" & _
      "Extended Properties=Excel 8.0;"
 On Error Resume Next
 Set cn = CreateObject("ADODB.Connection")
 cn.Open link_opt
 On Error GoTo 0

 '接続OKの場合
 If Not cn Is Nothing And Err.Number = 0 Then
   mysql = "SELECT 日付 AS 抽出, 店舗, 項目, [1係], [2係], [3係] " & _
       "FROM [" & WS1.Name & "$" & rng1.Address(0, 0) & "] " & _
       "WHERE 日付=""20070402"" AND 店舗=""本店"" "
   mysql = mysql & " " & "UNION ALL "
   mysql = mysql & "SELECT ""累計"" AS 抽出, 店舗, 項目, Sum([1係]) AS 1係, Sum([2係]) AS 2係, Sum([3係]) AS 3係 " & _
       "FROM [" & WS1.Name & "$" & rng1.Address(0, 0) & "] " & _
       "WHERE 日付<=""20070402"" " & _
       "GROUP BY ""累計"", 店舗, 項目 " & _
       "HAVING 店舗=""本店"" "
  
  'データベースを開く
  On Error Resume Next
  Set rs = cn.Execute(mysql)
  On Error GoTo 0
   
  'データ取得
  If Not rs Is Nothing And Err.Number = 0 Then
   With WS2
    .Cells.ClearContents
    For idx = 0 To rs.fields.Count - 1
     .Cells(1, idx + 1).Value = rs.fields(idx).Name
    Next
    .Range("A2").CopyFromRecordset rs
    .Range("A1").CurrentRegion.Sort Key1:=Range("A2"), Order1:=xlAscending, _
     Key2:=Range("C2"), Order2:=xlDescending, Header:=xlGuess
   End With
  Else
   MsgBox "レコードセットを開けません"
  End If
  
  'データベースを閉じる
  On Error Resume Next
  rs.Close
  Set rs = Nothing
  On Error GoTo 0
  
  '接続を切断する
  On Error Resume Next
  cn.Close
  Set cn = Nothing
  On Error GoTo 0

 Else
  MsgBox "データベースに接続できません"
 End If
End Sub

【48754】Re:オートフィルターについて
発言  hiro  - 07/5/4(金) 20:09 -

引用なし
パスワード
   ▼かみちゃん さん:
>親切なご回答ありがとうございます
SQLはまったくわかりませんが 頂いたコードでテストさせていただきました
がレコードセットをひらけません のメッセージが出ます。どこか私の方で修正しないとだめでしょうか?よろしくお願いいたします

【48755】Re:オートフィルターについて
発言  かみちゃん E-MAIL  - 07/5/4(金) 20:39 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>SQLはまったくわかりませんが 頂いたコードでテストさせていただきました
>がレコードセットをひらけません のメッセージが出ます。

こちらでは動作確認できているのですが、
保存していない新規ブックの場合は、そのMsgBoxが表示されることを確認しました。
そのため、保存していない新規ブックで試されているのであれば、一度保存して
試してみてください。

なお、以下のコードは、Sheet2をアクティブにしていない場合、エラーになりますので、
    .Range("A1").CurrentRegion.Sort Key1:=Range("A2"), Order1:=xlAscending, _
     Key2:=Range("C2"), Order2:=xlDescending, Header:=xlGuess

    .Range("A1").CurrentRegion.Sort Key1:=.Range("A2"), Order1:=xlAscending, _
     Key2:=.Range("C2"), Order2:=xlDescending, Header:=xlGuess
としてください。

【48760】Re:オートフィルターについて
回答  Hirofumi  - 07/5/5(土) 3:53 -

引用なし
パスワード
   オートフィルタを使わずに、単純な手法で行っています
1、Listを「店舗」昇順、「日付」昇順で整列します
 ただ、今回のコードでは、Listを元に戻す為、最終列の後ろに再整列用のKeyを
 先に出力しています
2、Listの「店舗」を上から見ていきます、探索KeyのKeyB1と同じ値が有った場合
 KeyA1の値になるまで集計を行います
3、次にListの「日付」を見て行き、KeyA1と同じ値が初めて有った時
 この行位置を記録し、同じ値の行をカウントしていきます
4、Listの「店舗」が違ったら、集計とカウントを辞めます
5、lngTopで記録した行位置から、カウントした行数を、List2にCopyし、
 集計結果を出力して終わります


Option Explicit

Public Sub Sample()

  '◆Listのデータ列数(A列〜AG列)
  Const clngColumns As Long = 33
  '◆「1係」の列位置を指定(基準セル位置からの列Offset:基準がA1で「1係」がD列なら3)
  Const clngBegin As Long = 3
  '◆「日付」の列位置を指定(基準セル位置からの列Offset:基準がA1で「日付」がA列なら0)
  Const clngDate As Long = 0
  '◆「店舗」の列位置を指定(基準セル位置からの列Offset:基準がA1で「店舗」がB列なら1)
  Const clngKey As Long = 1
  '◆「項目」の列位置を指定(基準セル位置からの列Offset:基準がA1で「項目」がC列なら2)
  Const clngItem As Long = 2
  
  Dim i As Long
  Dim j As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim vntDate As Variant
  Dim vntKeys As Variant
  Dim vntItems As Variant
  Dim rngResult As Range
  Dim vntResult As Variant
  Dim vntData As Variant
  Dim vntKeyA1 As Variant
  Dim vntKeyB1 As Variant
  Dim lngTop As Long
  Dim lngCount As Long
  Dim lngIndex As Long
  Dim strProm As String

  '◆Listの先頭セル位置を基準とする(列見出し「日付」のセル位置)
  Set rngList = Worksheets("List").Cells(1, "A")

  '◆List2の先頭セル位置を基準とする(列見出し「日付」のセル位置)
  Set rngResult = Worksheets("List2").Cells(5, "A")
  
  With rngResult
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row, clngItem).End(xlUp).Row - .Row
    If lngRows > 0 Then
      '先回の結果をクリア (結果表示先List2のA:AF)
      .Offset(1).Resize(lngRows, clngColumns - 1).ClearContents
    End If
    '「日付」の抽出条件を取得
    vntKeyA1 = .Parent.Cells(2, 2).Value
    '「店舗」の抽出条件を取得
    vntKeyB1 = .Parent.Cells(3, 2).Value
  End With

  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '復帰用整列Keyを作成
    ReDim vntData(1 To lngRows, 1 To 1)
    For i = 1 To lngRows
      vntData(i, 1) = i
    Next i
    '復帰用Keyの出力
    .Offset(1, clngColumns) _
          .Resize(lngRows).Value = vntData
    'データを「店舗」昇順の「日付」昇順で整列
    .Offset(1).Resize(lngRows, clngColumns + 1).Sort _
        Key1:=.Offset(1, clngKey), Order1:=xlAscending, _
        Key2:=.Offset(1, clngDate), Order2:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '「日付」列データを配列に取得
    vntDate = .Offset(1, clngDate).Resize(lngRows + 1).Value
    '「店舗」列データを配列に取得
    vntKeys = .Offset(1, clngKey).Resize(lngRows + 1).Value
    '「項目」列データを配列に取得
    vntItems = .Offset(1, clngItem).Resize(lngRows + 1).Value
  End With
  
  '結果出力用配列を確保(売上と差益の累計値の集計用)
  ReDim vntResult(1, clngColumns - clngBegin)
  vntResult(0, 0) = "売上累計"
  vntResult(1, 0) = "差益累計"
  'Listのデータ行全てに就いて繰り返し
  For i = 1 To lngRows
    '「店舗」の値がKeyB1の値と合致した場合
    If StrComp(vntKeys(i, 1), vntKeyB1, vbTextCompare) = 0 Then
      '「日付」がKeyA1の値以下の場合
      If vntDate(i, 1) <= vntKeyA1 Then
        '項目が「売上」か"差益"なら
        If vntItems(i, 1) = "売上" Or vntItems(i, 1) = "差益" Then
          '1行分データを配列に取得
          vntData = rngList.Offset(i, clngBegin) _
                .Resize(, clngColumns - clngBegin).Value
          '項目が「売上」なら
          If vntItems(i, 1) = "売上" Then
            lngIndex = 0
          Else
            lngIndex = 1
          End If
          '「係」 単位に集計
          For j = 1 To clngColumns - clngBegin
            vntResult(lngIndex, j) _
                = vntResult(lngIndex, j) + vntData(1, j)
          Next j
        End If
        '「日付」がKeyA1の値合致し、lngTopが0の場合
        If vntDate(i, 1) = vntKeyA1 And lngTop = 0 Then
          '抽出行の先頭行位置を記録
          lngTop = i
          '抽出行数を1に
          lngCount = 1
        Else
          '抽出行数を更新
          lngCount = lngCount + 1
        End If
      End If
    Else
      '探索するKeyB1を通り過ぎた場合
      If lngTop > 0 Then
        'Forを抜ける
        Exit For
      End If
    End If
  Next i
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '結果を出力
  With rngResult
    '抽出結果が有るなら
    If lngTop > 0 Then
      '列見出しを貼り付け
      rngList.Offset(, 1).Resize(lngCount, _
          clngColumns - 1).Copy Destination:=.Item(1)
      '抽出結果を貼り付け
      rngList.Offset(lngTop, 1).Resize(lngCount, _
          clngColumns - 1).Copy Destination:=.Offset(1)
      '累計を出力
      .Offset(lngCount + 1, 1).Resize(2, clngColumns _
                  - clngBegin).Value = vntResult
      strProm = "処理が完了しました"
    Else
      strProm = "抽出結果が有りません"
    End If
  End With
  
  With rngList
    'Listの再整列
    .Offset(1).Resize(lngRows, clngColumns + 1).Sort _
        Key1:=.Offset(1, clngColumns), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    'Key列の削除
    .Offset(1, clngColumns).EntireColumn.Delete
  End With
  
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

【48761】Re:オートフィルターについて
回答  Hirofumi  - 07/5/5(土) 11:31 -

引用なし
パスワード
   AdvancedFilterを使って

Option Explicit

Public Sub Sample2()

  '◆Listのデータ列数(A列〜AG列)
  Const clngColumns As Long = 33
  '◆「1係」の列位置を指定(基準セル位置からの列Offset:基準がA1で「1係」がD列なら3)
  Const clngBegin As Long = 3
  '◆「日付」の列位置を指定(基準セル位置からの列Offset:基準がA1で「日付」がA列なら0)
  Const clngDate As Long = 0
  '◆「店舗」の列位置を指定(基準セル位置からの列Offset:基準がA1で「店舗」がB列なら1)
  Const clngKey As Long = 1
  '◆「項目」の列位置を指定(基準セル位置からの列Offset:基準がA1で「項目」がC列なら2)
  Const clngItem As Long = 2
  
  Dim i As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim rngResult As Range
  Dim vntResult As Variant
  Dim vntKeyA1 As Variant
  Dim vntKeyB1 As Variant
  Dim vntItem As Variant
  Dim strProm As String

  '◆Listの先頭セル位置を基準とする(列見出し「日付」のセル位置)
  Set rngList = Worksheets("List").Cells(1, "A")

  '◆List2の先頭セル位置を基準とする(列見出し「日付」のセル位置)
  Set rngResult = Worksheets("List2").Cells(5, "A")
  
  With rngList
    '行数の取得
    lngRows = .CurrentRegion.Rows.Count - 1
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
  End With
  
  '画面更新を停止
  Application.ScreenUpdating = False

  strProm = "抽出条件に一致するレコードが有りません"
  With rngResult
    '「日付」の抽出条件を取得
    vntKeyA1 = .Parent.Cells(2, 2).Value
    '「店舗」の抽出条件を取得
    vntKeyB1 = .Parent.Cells(3, 2).Value
    '先回の結果をクリア (結果表示先List2のA:AF)
    .CurrentRegion.ClearContents
    '列見出しを貼り付け
    rngList.Resize(, clngColumns).Copy Destination:=.Item(1)
    'AdvancedFilter条件範囲の列見出しの出力
    With .Offset(, clngColumns)
      .Offset(, 1).Value = rngList.Offset(, clngDate).Value
      .Offset(, 2).Value = rngList.Offset(, clngKey).Value
      .Offset(, 3).Value = rngList.Offset(, clngItem).Value
    End With
    '「項目」列の抽出条件文字列を設定
    vntItem = Array("売上", "差益")
    '集計結果の格納用配列を確保
    ReDim vntResult(UBound(vntItem))
    '☆KeyA1の値以下の日付で、KeyB1の店舗で
    '日付条件を出力
    .Offset(1, clngColumns + 1).Value = "<=" & vntKeyA1
    '店舗条件を出力
    .Offset(1, clngColumns + 2).Value = vntKeyB1
    '売上、差益を抽出し、集計
    For i = 0 To UBound(vntItem)
      '項目条件を出力
      .Offset(1, clngColumns + 3).Value = vntItem(i)
      'AdvancedFilterを実行
      DoFilter rngList.CurrentRegion, .Offset(, clngColumns + 1) _
                  .Resize(2, 3), .Resize(, clngColumns)
      'データ行数を取得
      lngRows = .CurrentRegion.Rows.Count
      '売上データを集計
      With .Offset(lngRows, clngBegin).Resize(, clngColumns - clngBegin)
        '範囲に関数を設定
        .FormulaR1C1 = "=Sum(R[-" & lngRows & "]C:R[-1]C)"
      End With
      '範囲を配列に取得
      vntResult(i) = .Offset(lngRows).Resize(, clngColumns).Value
      vntResult(i)(1, clngItem + 1) = vntItem(i) & "累計"
    Next i
    '☆KeyA1の値の日付で、KeyB1の店舗のデータを抽出
    '日付条件を出力
    .Offset(1, clngColumns + 1).Value = vntKeyA1
    'AdvancedFilterを実行
    DoFilter rngList.CurrentRegion, .Offset(, clngColumns + 1) _
                .Resize(2, 2), .Resize(, clngColumns)
    'データ行数を取得
    lngRows = .CurrentRegion.Rows.Count
    '抽出データがない場合
    If lngRows = 1 Then
      GoTo Wayout
    End If
    '売上、差益データを出力
    For i = 0 To 1
      .Offset(lngRows + i).Resize(, clngColumns).Value = vntResult(i)
    Next i
  End With
  
  strProm = "処理が完了しました"
  
Wayout:

  With rngResult
    '抽出条件範囲を削除
    .Offset(, clngColumns + 1).Resize(, 3).EntireColumn.Delete
    '先頭日付範囲を削除
    .Resize(lngRows + 2).Delete
  End With

  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

Private Sub DoFilter(rngScope As Range, _
          rngCriteria As Range, _
          rngCopyTo As Range)
  
'  AdvancedFilterの実行

  rngScope.AdvancedFilter _
      Action:=xlFilterCopy, _
      CriteriaRange:=rngCriteria, _
      CopyToRange:=rngCopyTo, _
      Unique:=False
    
End Sub

【48762】Re:オートフィルターについて
発言  hiro  - 07/5/5(土) 22:16 -

引用なし
パスワード
   かみちゃん様 Hirofumi 様
ご丁寧な回答誠にありがとうございます
只今帰宅し頂いたサンプルを実行いたしました みごとに成功いたしました
まだまだ初心者で技術的には 理解できていませんが Hirofumi 様のAdvancedFilterを使わしていただきました それにしてもお二人のスキルはほんとにすごいですね 貴重なお時間をさいて頂きありがとうございました。
返事が遅くったことをお詫びいたします

hirofumi様にもう一つお聞きしたいのですが出力のさいにできれば行列を入れ替えたいのですが可能でしょうか?

店舗    本店    本店    本店        
項目    売上    差益    在庫    売上累計    差益累計
1係    1    2    3    2    4
2係    1    2    3    2    4
3係    1    2    3    2    4
4係    1    2    3    2    4
5係    1    2    3    2    4

あつかましい質問ばかりですいません お時間のあるときにご指導ください

【48763】Re:オートフィルターについて
回答  Hirofumi  - 07/5/5(土) 23:37 -

引用なし
パスワード
   >hirofumi様にもう一つお聞きしたいのですが出力のさいに
>できれば行列を入れ替えたいのですが可能でしょうか?

「Sub Sample2」(AdvancedFilter版)のコードは、
出力もAdvancedFilterに依存していますので無理です
ただし、「Sub Sample」の方は、行列を入れ替える方法を採れば可能です

Option Explicit

Public Sub Sample3()

  '◆Listのデータ列数(A列〜AG列)
  Const clngColumns As Long = 33
  '◆「1係」の列位置を指定(基準セル位置からの列Offset:基準がA1で「1係」がD列なら3)
  Const clngBegin As Long = 3
  '◆「日付」の列位置を指定(基準セル位置からの列Offset:基準がA1で「日付」がA列なら0)
  Const clngDate As Long = 0
  '◆「店舗」の列位置を指定(基準セル位置からの列Offset:基準がA1で「店舗」がB列なら1)
  Const clngKey As Long = 1
  '◆「項目」の列位置を指定(基準セル位置からの列Offset:基準がA1で「項目」がC列なら2)
  Const clngItem As Long = 2
  
  Dim i As Long
  Dim j As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim vntDate As Variant
  Dim vntKeys As Variant
  Dim vntItems As Variant
  Dim rngResult As Range
  Dim vntResult As Variant
  Dim vntData As Variant
  Dim vntKeyA1 As Variant
  Dim vntKeyB1 As Variant
  Dim lngTop As Long
  Dim lngCount As Long
  Dim lngIndex As Long
  Dim strProm As String

  '◆Listの先頭セル位置を基準とする(列見出し「日付」のセル位置)
  Set rngList = Worksheets("List").Cells(1, "A")

  '◆List2の先頭セル位置を基準とする(列見出し「日付」のセル位置)
  Set rngResult = Worksheets("List2").Cells(5, "A")
  '結果表の出力を右1列ずらす例
'  Set rngResult = Worksheets("List2").Cells(5, "B")
  
  With rngResult
    '先回の結果をクリア
    .CurrentRegion.ClearContents '★変更
    '「日付」の抽出条件を取得
    vntKeyA1 = .Parent.Cells(2, 2).Value
    '「店舗」の抽出条件を取得
    vntKeyB1 = .Parent.Cells(3, 2).Value
  End With

  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '復帰用整列Keyを作成
    ReDim vntData(1 To lngRows, 1 To 1)
    For i = 1 To lngRows
      vntData(i, 1) = i
    Next i
    '復帰用Keyの出力
    .Offset(1, clngColumns) _
          .Resize(lngRows).Value = vntData
    'データを「店舗」昇順の「日付」昇順で整列
    .Offset(1).Resize(lngRows, clngColumns + 1).Sort _
        Key1:=.Offset(1, clngKey), Order1:=xlAscending, _
        Key2:=.Offset(1, clngDate), Order2:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '「日付」列データを配列に取得
    vntDate = .Offset(1, clngDate).Resize(lngRows + 1).Value
    '「店舗」列データを配列に取得
    vntKeys = .Offset(1, clngKey).Resize(lngRows + 1).Value
    '「項目」列データを配列に取得
    vntItems = .Offset(1, clngItem).Resize(lngRows + 1).Value
  End With
  
  '結果出力用配列を確保(売上と差益の累計値の集計用)
  ReDim vntResult(clngColumns - clngBegin, 1)    '★変更
  vntResult(0, 0) = "売上累計"           '★変更
  vntResult(0, 1) = "差益累計"           '★変更
  'Listのデータ行全てに就いて繰り返し
  For i = 1 To lngRows
    '「店舗」の値がKeyB1の値と合致した場合
    If StrComp(vntKeys(i, 1), vntKeyB1, vbTextCompare) = 0 Then
      '「日付」がKeyA1の値以下の場合
      If vntDate(i, 1) <= vntKeyA1 Then
        '項目が「売上」か"差益"なら
        If vntItems(i, 1) = "売上" Or vntItems(i, 1) = "差益" Then
          '1行分データを配列に取得
          vntData = rngList.Offset(i, clngBegin) _
                .Resize(, clngColumns - clngBegin).Value
          '項目が「売上」なら
          If vntItems(i, 1) = "売上" Then
            lngIndex = 0
          Else
            lngIndex = 1
          End If
          '「係」 単位に集計
          For j = 1 To clngColumns - clngBegin
            vntResult(j, lngIndex) _
                = vntResult(j, lngIndex) + vntData(1, j) '★変更
          Next j
        End If
        '「日付」がKeyA1の値合致し、lngTopが0の場合
        If vntDate(i, 1) = vntKeyA1 And lngTop = 0 Then
          '抽出行の先頭行位置を記録
          lngTop = i
          '抽出行数を1に
          lngCount = 1
        Else
          '抽出行数を更新
          lngCount = lngCount + 1
        End If
      End If
    Else
      '探索するKeyB1を通り過ぎた場合
      If lngTop > 0 Then
        'Forを抜ける
        Exit For
      End If
    End If
  Next i
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '結果を出力
  With rngResult
    '抽出結果が有るなら
    If lngTop > 0 Then
      '結果出力用配列を確保
      ReDim vntItems(1 To clngColumns - 1, lngCount) '★追加
      '列見出しを配列に取得
      vntData = rngList.Offset(, 1).Resize(lngCount, _
                  clngColumns - 1).Value '★変更
      '列見出しを行列変換して結果出力用配列に格納
      For i = 1 To clngColumns - 1          '★追加
        vntItems(i, 0) = vntData(1, i)       '★追加
      Next i                     '★追加
      '抽出結果を配列に取得
      vntData = rngList.Offset(lngTop, 1) _
          .Resize(lngCount, clngColumns - 1).Value '★変更
      'データを行列変換して結果出力用配列に格納
      For i = 1 To clngColumns - 1          '★追加
        For j = 1 To lngCount            '★追加
          vntItems(i, j) = vntData(j, i)     '★追加
        Next j                   '★追加
      Next i                     '★追加
      '結果を出力
      .Resize(clngColumns - 1, _
            lngCount + 1).Value = vntItems   '★追加
      .Offset(clngBegin - 2, lngCount + 1) _
          .Resize(clngColumns - clngBegin + 1, _
              2).Value = vntResult      '★追加
      strProm = "処理が完了しました"
    Else
      strProm = "抽出結果が有りません"
    End If
  End With
  
  With rngList
    'Listの再整列
    .Offset(1).Resize(lngRows, clngColumns + 1).Sort _
        Key1:=.Offset(1, clngColumns), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    'Key列の削除
    .Offset(1, clngColumns).EntireColumn.Delete
  End With
  
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

【48764】Re:オートフィルターについて
回答  Hirofumi  - 07/5/6(日) 1:23 -

引用なし
パスワード
   >「Sub Sample2」(AdvancedFilter版)のコードは、
>出力もAdvancedFilterに依存していますので無理です

と言ったけど、Copyして行列を入れ替えたPasteを行えば可能の様です?
ただ、こうの様な方法は、私は好まないけど?

Option Explicit

Public Sub Sample4()

  '◆Listのデータ列数(A列〜AG列)
  Const clngColumns As Long = 33
  '◆「1係」の列位置を指定(基準セル位置からの列Offset:基準がA1で「1係」がD列なら3)
  Const clngBegin As Long = 3
  '◆「日付」の列位置を指定(基準セル位置からの列Offset:基準がA1で「日付」がA列なら0)
  Const clngDate As Long = 0
  '◆「店舗」の列位置を指定(基準セル位置からの列Offset:基準がA1で「店舗」がB列なら1)
  Const clngKey As Long = 1
  '◆「項目」の列位置を指定(基準セル位置からの列Offset:基準がA1で「項目」がC列なら2)
  Const clngItem As Long = 2
  
  Dim i As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim rngResult As Range
  Dim vntResult As Variant
  Dim vntKeyA1 As Variant
  Dim vntKeyB1 As Variant
  Dim vntItem As Variant
  Dim strProm As String

  '◆Listの先頭セル位置を基準とする(列見出し「日付」のセル位置)
  Set rngList = Worksheets("List").Cells(1, "A")

  '◆List2の先頭セル位置を基準とする(列見出し「日付」のセル位置)
  Set rngResult = Worksheets("List2").Cells(5, "A")
  
  With rngList
    '行数の取得
    lngRows = .CurrentRegion.Rows.Count - 1
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
  End With
  
  '画面更新を停止
  Application.ScreenUpdating = False

  strProm = "抽出条件に一致するレコードが有りません"
  With rngResult
    '「日付」の抽出条件を取得
    vntKeyA1 = .Parent.Cells(2, 2).Value
    '「店舗」の抽出条件を取得
    vntKeyB1 = .Parent.Cells(3, 2).Value
    '先回の結果をクリア (結果表示先List2のA:AF)
    .CurrentRegion.ClearContents
    '列見出しを貼り付け
    rngList.Resize(, clngColumns).Copy Destination:=.Item(1)
    'AdvancedFilter条件範囲の列見出しの出力
    With .Offset(, clngColumns)
      .Offset(, 1).Value = rngList.Offset(, clngDate).Value
      .Offset(, 2).Value = rngList.Offset(, clngKey).Value
      .Offset(, 3).Value = rngList.Offset(, clngItem).Value
    End With
    '「項目」列の抽出条件文字列を設定
    vntItem = Array("売上", "差益")
    '集計結果の格納用配列を確保
    ReDim vntResult(UBound(vntItem))
    '☆KeyA1の値以下の日付で、KeyB1の店舗で
    '日付条件を出力
    .Offset(1, clngColumns + 1).Value = "<=" & vntKeyA1
    '店舗条件を出力
    .Offset(1, clngColumns + 2).Value = vntKeyB1
    '売上、差益を抽出し、集計
    For i = 0 To UBound(vntItem)
      '項目条件を出力
      .Offset(1, clngColumns + 3).Value = vntItem(i)
      'AdvancedFilterを実行
      DoFilter rngList.CurrentRegion, .Offset(, clngColumns + 1) _
                  .Resize(2, 3), .Resize(, clngColumns)
      'データ行数を取得
      lngRows = .CurrentRegion.Rows.Count
      '売上データを集計
      With .Offset(lngRows, clngBegin).Resize(, clngColumns - clngBegin)
        '範囲に関数を設定
        .FormulaR1C1 = "=Sum(R[-" & lngRows & "]C:R[-1]C)"
      End With
      '範囲を配列に取得
      vntResult(i) = .Offset(lngRows).Resize(, clngColumns).Value
      vntResult(i)(1, clngItem + 1) = vntItem(i) & "累計"
    Next i
    '☆KeyA1の値の日付で、KeyB1の店舗のデータを抽出
    '日付条件を出力
    .Offset(1, clngColumns + 1).Value = vntKeyA1
    'AdvancedFilterを実行
    DoFilter rngList.CurrentRegion, .Offset(, clngColumns + 1) _
                .Resize(2, 2), .Resize(, clngColumns)
    'データ行数を取得
    lngRows = .CurrentRegion.Rows.Count
    '抽出データがない場合
    If lngRows = 1 Then
      .CurrentRegion.ClearContents '★追加
      GoTo Wayout
    End If
    '売上、差益データを出力
    For i = 0 To UBound(vntItem) '★変更
      .Offset(lngRows + i).Resize(, clngColumns).Value = vntResult(i)
    Next i
  '******<以下コード追加部分>*******
    '結果範囲をCopy
    .CurrentRegion.Copy
    '出力結果の下に行列を入れ替えPaste
    i = UBound(vntItem) + 1
    .Offset(lngRows + i).PasteSpecial _
        Paste:=xlPasteAll, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=True
    Application.CutCopyMode = False
    Set rngResult = .Offset(lngRows + i + 1)
  '*****<以上コード追加部分>*****
  End With
  '*****<以下コード追加部分>*****
  'Copy元のデータ行を削除
  With rngResult
    .Offset(-(lngRows + i + 1)).Resize(lngRows + i + 1).EntireRow.Delete
    .Parent.Activate
    .Select
  End With
  '*****<以上コード追加部分>******
  
  strProm = "処理が完了しました"
  
Wayout:

'  With rngResult '★削除
    '抽出条件範囲を削除
'    .Offset(, clngColumns + 1).Resize(, 3).EntireColumn.Delete '★削除
    '先頭日付範囲を削除
'    .Resize(lngRows + 2).Delete '★削除
'  End With '★削除

  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  Set rngResult = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

Private Sub DoFilter(rngScope As Range, _
          rngCriteria As Range, _
          rngCopyTo As Range)
  
'  AdvancedFilterの実行

  rngScope.AdvancedFilter _
      Action:=xlFilterCopy, _
      CriteriaRange:=rngCriteria, _
      CopyToRange:=rngCopyTo, _
      Unique:=False
    
End Sub

【48767】Re:オートフィルターについて
回答  Hirofumi  - 07/5/6(日) 18:37 -

引用なし
パスワード
   後から思ったのですが、「Sub Sample4」では、Worksheets("List2")に、
書式(罫線、列幅、セル書式等)が設定してあった場合、それを崩してしまうので、
抽出をWorksheets("List2")上で行わず、作業シートを作成してこの上で抽出し、
Worksheets("List2")に整形して貼り付ける方法に変更します

尚、書き忘れていましたが、◆印の付いたコードは、パラメタとして変更可能な項目です
List、List2の仕様で変更して下さい

Option Explicit

Public Sub Sample5()

  '◆Listのデータ列数(A列〜AG列)
  Const clngColumns As Long = 33
  '◆「1係」の列位置を指定(基準セル位置からの列Offset:基準がA1で「1係」がD列なら3)
  Const clngBegin As Long = 3
  '◆「日付」の列位置を指定(基準セル位置からの列Offset:基準がA1で「日付」がA列なら0)
  Const clngDate As Long = 0
  '◆「店舗」の列位置を指定(基準セル位置からの列Offset:基準がA1で「店舗」がB列なら1)
  Const clngKey As Long = 1
  '◆「項目」の列位置を指定(基準セル位置からの列Offset:基準がA1で「項目」がC列なら2)
  Const clngItem As Long = 2
  
  Dim i As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim rngResult As Range
  Dim rngWork As Range
  Dim vntResult As Variant
  Dim vntKeyA1 As Variant
  Dim vntKeyB1 As Variant
  Dim vntItem As Variant
  Dim strProm As String

  '◆Listの先頭セル位置を基準とする(列見出し「日付」のセル位置)
  Set rngList = Worksheets("List").Cells(1, "A")

  '◆List2の先頭セル位置を基準とする(列見出し「日付」のセル位置)
  Set rngResult = Worksheets("List2").Cells(5, "A")
  Set rngResult = Worksheets("List2").Cells(5, "B")
  
  '◆「項目」列の抽出条件文字列を設定
  vntItem = Array("売上", "差益")
  
  With rngList
    '行数の取得
    lngRows = .CurrentRegion.Rows.Count - 1
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
  End With
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  With rngResult
    '「日付」の抽出条件を取得
    vntKeyA1 = .Parent.Cells(2, 2).Value
    '「店舗」の抽出条件を取得
    vntKeyB1 = .Parent.Cells(3, 2).Value
    '先回の結果をクリア (結果表示先List2のA:AF)
    .CurrentRegion.ClearContents
  End With
  
  '作業用シートを追加
  With Worksheets
    Set rngWork = .Add(After:=.Item(.Count)).Cells(1, "A")
  End With

  With rngWork
    '列見出しを貼り付け
    rngList.Resize(, clngColumns).Copy Destination:=.Item(1)
    'AdvancedFilter条件範囲の列見出しの出力
    With .Offset(, clngColumns)
      .Offset(, 1).Value = rngList.Offset(, clngDate).Value
      .Offset(, 2).Value = rngList.Offset(, clngKey).Value
      .Offset(, 3).Value = rngList.Offset(, clngItem).Value
    End With
    '集計結果の格納用配列を確保
    ReDim vntResult(UBound(vntItem))
    '☆KeyA1の値以下の日付で、KeyB1の店舗で
    '日付条件を出力
    .Offset(1, clngColumns + 1).Value = "<=" & vntKeyA1
    '店舗条件を出力
    .Offset(1, clngColumns + 2).Value = vntKeyB1
    '売上、差益を抽出し、集計
    For i = 0 To UBound(vntItem)
      '項目条件を出力
      .Offset(1, clngColumns + 3).Value = vntItem(i)
      'AdvancedFilterを実行
      DoFilter rngList.CurrentRegion, .Offset(, clngColumns + 1) _
                  .Resize(2, 3), .Resize(, clngColumns)
      'データ行数を取得
      lngRows = .CurrentRegion.Rows.Count
      '売上データを集計
      With .Offset(lngRows, clngBegin).Resize(, clngColumns - clngBegin)
        '範囲に関数を設定
        .FormulaR1C1 = "=Sum(R[-" & lngRows & "]C:R[-1]C)"
      End With
      '範囲を配列に取得
      vntResult(i) = .Offset(lngRows).Resize(, clngColumns).Value
      vntResult(i)(1, clngItem + 1) = vntItem(i) & "累計"
    Next i
    '☆KeyA1の値の日付で、KeyB1の店舗のデータを抽出
    '日付条件を出力
    .Offset(1, clngColumns + 1).Value = vntKeyA1
    'AdvancedFilterを実行
    DoFilter rngList.CurrentRegion, .Offset(, clngColumns + 1) _
                .Resize(2, 2), .Resize(, clngColumns)
    'データ行数を取得
    lngRows = .CurrentRegion.Rows.Count
    '抽出データがない場合
    If lngRows = 1 Then
      strProm = "抽出条件に一致するレコードが有りません"
      rngResult.Parent.Activate
      GoTo Wayout
    End If
    '売上、差益データを出力
    For i = 0 To UBound(vntItem)
      .Offset(lngRows + i).Resize(, clngColumns).Value = vntResult(i)
    Next i
    '結果範囲をCopy
    Application.Intersect(.CurrentRegion, .CurrentRegion.Offset(, 1)).Copy
  End With
  
  With rngResult
    '出力結果の下に行列を入れ替え値のみPaste
    .PasteSpecial Paste:=xlPasteValues, _
        Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=True
    Application.CutCopyMode = False
    .Parent.Activate
    .Select
  End With
  
  strProm = "処理が完了しました"
  
Wayout:

  '作業シートを削除
  If Not rngWork Is Nothing Then
    Application.DisplayAlerts = False
    rngWork.Parent.Delete
    Application.DisplayAlerts = True
  End If
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngWork = Nothing
  Set rngList = Nothing
  Set rngResult = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

Private Sub DoFilter(rngScope As Range, _
          rngCriteria As Range, _
          rngCopyTo As Range)
  
'  AdvancedFilterの実行

  rngScope.AdvancedFilter _
      Action:=xlFilterCopy, _
      CriteriaRange:=rngCriteria, _
      CopyToRange:=rngCopyTo, _
      Unique:=False
    
End Sub

【48768】Re:オートフィルターについて
お礼  hiro  - 07/5/6(日) 21:24 -

引用なし
パスワード
   ▼Hirofumi 様何度も訂正していただきありがとうございます。
希望のとおりの結果を抽出できました 感謝いたします
お手数かけてすいませんでした

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