2

各基準を反復するために、リスト内のすべての異なるオートフィルター基準を取得する方法があるかどうか疑問に思っていました。最後に、反復時に別のシートに表示されるそれぞれの異なるテーブルをコピーして貼り付けます。

理想的には、これは n 回実行されます。

ActiveSheet.Range(AllRows).AutoFilter Field:=10, Criteria1:=CritVariable

ここで、n は異なる CritVariables の数です。

マクロ自体をコピーして貼り付ける方法を知っていることを強調したいのですが、日によって基準が異なる可能性があるため、さまざまな基準をすべて反復する方法に興味がありました. そのリストが利用できない場合、どのように基準を反復するのが最善でしょうか?

4

3 に答える 3

1

遅くなり、すでに回答を選択していることはわかっていますが、ピボットテーブルを含む同様のプロジェクトに取り組んでおり、次のようにすることにしました。

'Here I'm Filtering a column of Week numbers to get rid of non-numbers
'From a pivot table

'I select sheet where my underlying pivot data is located and establish the range
'My data is in column 2 and it ends after "DSLastRow" Rows starting at Row 2

Sheets("DataSheet").Select
DSLastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

'I create and redim an array that is large enough to hold all of the data in the range
Dim FilterCriteria(): RedimFilterCriteria(1 To DSLastRow)

For r = 2 To DSLastRow 'r for row / my data has a header in row 1
    If Cells(r, 2).Value <> "" Then 'again, starting in column B (2)
        'Check if it's already in the FilterCriteria Array
        For CheckFCA = 1 To r
            'Jumps to next row if it finds a match
            If FilterCriteria(CheckFCA) = Cells(r, 2).Value Then GoTo Nextr
            'Saves the value and jumps to next row if it reaches an empty value in the array
            If IsEmpty(FilterCriteria(CheckFCA)) Then
                FilterCriteria(CheckFCA) = Cells(r, 2)
                GoTo Nextr
            End If
        Next CheckFCA
    End if
Nextr:
Next r
'At this point FilterCriteria() is filled with all of the unique values

'I'm filtering a pivot table which is why I created the unique array from
'the source data, but you should be able to just loop through the table
Sheets("Pivot").Select
ActiveSheet.PivotTables("ReportPivot").PivotFields("Week").ClearAllFilters
With ActiveSheet.PivotTables("ReportPivot").PivotFields("Week")
    For FilterPivot = 1 To DSLastRow
        'I'm filtering out all non-numeric items
        If IsEmpty(FilterCriteria(FilterPivot)) Then Exit For
        If Not IsNumeric(FilterCriteria(FilterPivot)) Then
            .PivotItems(FilterCriteria(FilterPivot)).Visible = False
        End If
    Next FilterPivot
End With
于 2015-12-01T18:41:37.457 に答える
1

以下を学習して適応させることができます。これが何が起こっているかの概要です。

  • セル A5 から始まるスタッフ テーブルがあり、列 G にオフィスのリストがあります。
  • G5 から下に向かって (この列のデータに空白がないと仮定して) W1 にコピーしています。
  • 範囲 W1 から下に向かって重複を削除しています。
  • 次に、高度なフィルターを使用して、各オフィスのデータをセル Z1 から始まる領域にコピーし、このデータをループ処理します。
  • このフィルター処理されたデータは、現在の Office 名 (条件) から名前が付けられた新しいワークシートに移動 (カット) されます。
  • 各高度なフィルターの後、セル W2 が削除され、W3 の値が上に移動して、次のフィルター操作に使用できるようになります。

これは、最後に使用したセルに移動するために Ctrl-End を押すと、必要以上に移動することを意味します。必要に応じて、これを解決する方法を見つけることができます;)。

Sub SheetsFromFilter()
    Dim wsCurrent As Worksheet
    Dim wsNew As Worksheet
    Dim iLeft As Integer

    Set wsCurrent = ActiveSheet
    Application.ScreenUpdating = False
    Range("G5", Range("G5").End(xlDown)).Copy Range("W1")
    Range("W1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
    iLeft = Range("W1").CurrentRegion.Rows.Count - 1
    Do While iLeft > 0
        wsCurrent.Range("A5").CurrentRegion.AdvancedFilter xlFilterCopy, _
            wsCurrent.Range("W1:W2"), wsCurrent.Range("Z1")
        Set wsNew = Worksheets.Add
        wsCurrent.Range("Z1").CurrentRegion.Cut wsNew.Range("A1")
        wsNew.Name = wsCurrent.Range("W2").Value
        wsCurrent.Range("W2").Delete xlShiftUp
        iLeft = iLeft - 1
    Loop
    wsCurrent.Range("W1").Clear
    Application.ScreenUpdating = True
End Sub

ところで、特定のファイル用にこれを変更するつもりはありません。これはあなたがやるべきことです（または誰かにお金を払ってください;））。

ところで、通常の (Advanced ではなく) Filter を使用して行うことができます。列をコピーして重複を削除します。これには、ワークシートの見かけのサイズを大きくしすぎないという利点があります。しかし、私はこのようにすることにしました;)。

追加:まあ、オートフィルターでもこれを達成することに触発されました:

Sub SheetsFromAutoFilter()
    Dim wsCurrent As Worksheet
    Dim wsNew As Worksheet
    Dim iLeft As Integer

    Set wsCurrent = ActiveSheet
    Application.ScreenUpdating = False
    Range("G5", Range("G5").End(xlDown)).Copy Range("W1")
    Range("W1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
    iLeft = Range("W1").CurrentRegion.Rows.Count - 1
    Do While iLeft > 0
        Set wsNew = Worksheets.Add
        With wsCurrent.Range("A5").CurrentRegion
            .AutoFilter field:=7, _
                Criteria1:=wsCurrent.Range("W1").Offset(iLeft).Value
            .Copy wsNew.Range("A1")
            .AutoFilter
        End With
        wsNew.Name = wsCurrent.Range("W1").Offset(iLeft).Value
        iLeft = iLeft - 1
    Loop
    wsCurrent.Range("W1").CurrentRegion.Clear
    Application.ScreenUpdating = True
End Sub

[両方の手順は、定義済みの名前といくつかのエラー処理/チェックを使用して改善できます。]

于 2013-06-20T19:12:59.693 に答える