Excel VBA質問箱 IV

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

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


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

【62796】フィルター繰り返し印刷 しゅう 09/9/3(木) 1:41 質問[未読]
【62797】Re:フィルター繰り返し印刷 ichinose 09/9/3(木) 7:11 発言[未読]
【62798】Re:フィルター繰り返し印刷 Hirofumi 09/9/3(木) 8:37 回答[未読]
【62802】Re:フィルター繰り返し印刷 しゅう 09/9/3(木) 12:34 お礼[未読]

【62796】フィルター繰り返し印刷
質問  しゅう  - 09/9/3(木) 1:41 -

引用なし
パスワード
   VBA初心者です。宜しくお願いします。



種類    品番  品名  
AAA  123441  ドア右
AAA  123442  ドア左
BBB  123881  マド右
BBB  123882  マド左
CCC  123991  ガラス右
CCC  123992  ガラス左

この表でオートフィルターをかけて
種類の列で抽出して印刷を繰り返したい。
マクロの記録をすると以下の通りです。
Sub Macro1()
  Range("A1").Select
  Selection.AutoFilter
  Selection.AutoFilter Field:=1, Criteria1:="AAA"
  ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
  Selection.AutoFilter Field:=1, Criteria1:="BBB"
  ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
  Selection.AutoFilter Field:=1, Criteria1:="CCC"
  ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
  Selection.AutoFilter Field:=1
End Sub
これだと種類が増えた時に対応できません。
過去ログを検索しましたが参考になるものが見つかりませんでした。
どなたか教えて下さい。
宜しくお願いします。

【62797】Re:フィルター繰り返し印刷
発言  ichinose  - 09/9/3(木) 7:11 -

引用なし
パスワード
   ▼しゅう さん:
おはようございます。

>例
>
>種類    品番  品名  
>AAA  123441  ドア右
>AAA  123442  ドア左
>BBB  123881  マド右
>BBB  123882  マド左
>CCC  123991  ガラス右
>CCC  123992  ガラス左
>
>これだと種類が増えた時に対応できません。
上記表がA1から始まっているとして、
A列の種類という項目の重複なしのリストが必要ですよね!!
フィルタオプションを使いました。
しゅう さんの考えたコードを使うと

'==============================================================
Sub Macro1()
  Dim Urng As Range
  Dim Erng As Range
  With Range("a1", Cells(Rows.Count, "a").End(xlUp))
    .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    On Error Resume Next
    Set Urng = .SpecialCells(xlCellTypeVisible)
    If Err.Number = 0 Then
     With .Resize(, 3)
       .AutoFilter
       For Each Erng In Urng
        If Erng.Address <> Urng.Cells(1).Address Then
          .AutoFilter Field:=1, Criteria1:=Erng.Value
          ActiveSheet.PrintPreview
'         activesheet.printout ↑プレビューしてあります
        End If
       Next
       .AutoFilter
     End With
    End If
    On Error GoTo 0
  End With
End Sub

【62798】Re:フィルター繰り返し印刷
回答  Hirofumi  - 09/9/3(木) 8:37 -

引用なし
パスワード
   ichinoseさんの種類項目の無重複Listの取り方を別の方法で行っています

Option Explicit

Sub Macro2()

  Dim i As Long
  Dim vntList As Variant
  Dim strEmn As String
  
  With Range("A1", Cells(Rows.Count, "A").End(xlUp))
    '配列に種類列を取得
    vntList = .Value
    'データが無い場合
    If VarType(vntList) <> vbArray + vbVariant Then
      Exit Sub
    End If
    '列挙文字列に初期値設定
    strEmn = vbTab
    '種類列の2番目から最後まで繰り返し
    For i = 2 To UBound(vntList, 1)
      '列挙文字列に現在の種類が無い場合
      If InStr(1, strEmn, vbTab & vntList(i, 1) & vbTab, vbTextCompare) = 0 Then
        '列挙文字列に種類を追加
        strEmn = strEmn & vntList(i, 1) & vbTab
      End If
    Next i
    '列挙した種類を配列に変換
    vntList = Split(Mid(strEmn, 2, Len(strEmn) - 2), vbTab)
    With .Resize(, 3)
      .AutoFilter
      For i = 0 To UBound(vntList, 1)
        .AutoFilter Field:=1, Criteria1:=vntList(i)
        ActiveSheet.PrintPreview
'        activesheet.printout ↑プレビューしてあります
      Next i
      .AutoFilter
    End With
  End With
  
End Sub

【62802】Re:フィルター繰り返し印刷
お礼  しゅう  - 09/9/3(木) 12:34 -

引用なし
パスワード
   ありがとうございます。
うまくいきました。
今まで25種類をフィルターを使って手動でやっていましたので随分楽になります。

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