Excel VBA質問箱 IV

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

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


33191 / 76734 ←次へ | 前へ→

【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

1 hits

【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 お礼

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