条件に基づいて複数のシートからリストを抽出する

Question

私が直面している問題はExcelに関するものです。私はいくつかの基準に基づいてシートの複数の列を持つ行を抽出しようとしています。私はこれに関するいくつかの解決策を見つけましたが、実際に私が探しているものは何もないか、それを動作させるために変更することはできません。私は例を使って以下でより詳細に説明する問題を説明しようとします。

状況：タスク

のリストを（SH8にSH1命名）

• 8枚の各シートは、タスクの種類を表す（個人、仕事を、...）
• 各シートは同じフォーマットを有する
• データは、行4から列A〜Kの間に配置される。
• 以下は、合計計算を伴う行
• は、データ（完了のために起動していないため、I進行中のため、N C）
が
• 列Dは、シートの
• スタイルが完全に条件使用して行われたタスクのステータスであるテキスト、数字、空白のセルを含みます私は「フィルタリングと呼ばれる新しいシートに、C、IまたはNのいずれかであること、それらの8枚コピーに特定のステータスです（空白のセルを含む）すべてのエントリをチェックし、何かをしたいと思います

のフォーマット"フィルタリングシートも同様のヘッダーを持つことになりますし、私はこれを始めたとき、データが行7

で開始する必要があり、私は（thisに基づく）式1枚のコピーのすべてのエントリことを思い付きました。私はC、IまたはNをフィルタリングシートのD4セルに入れてフィルタリングすることができました。

{ 
=IFERROR(
     INDEX(
       Sh1!A$4:A$19;SMALL(
            IF(
             Sh1!$D$4:$D19=Filtering!$D$4; 
             ROW(Sh1!A$4:A$19)-ROW(Sh1!A$4)+1 
            ); 
            ROWS(Sh1!A$4:Sh1!A4) 
           ) 
       ); 
     "") 
} 

私は、データが空白のセルが含まれているので、私は、空白のセルが0のに変わりはなかったことを確認するために、以下の計算式を変更し、前に言ったように：

{ 
=IFERROR(
     IF(
      INDEX(SAME AS ABOVE)=""; 
      ""; 
      INDEX(SAME AS ABOVE); 
      ); 
     "") 
} 

これはうまくいったものの、私はこれを1つのシートでしか実行できず、8つすべてではできませんでした。私はフィルタリングシートの下段にあるSh2を起動してこれを解決し、他のすべてのシートに対してこれを行うことができますが、それは実際には私が得たいものではありません。私は実際に、フィルタリングシート上のその1つのセルD4を変更することによって、開始されていない、完了されている、または進行中のすべてを合計する連続リストに行きたいと思います。

あなたの提案が欲しい場所です。 VBAなしでこれを行うことが可能なら、私は時々オンラインWebアプリケーションでそれを使用し、マクロはそこで動作しないので、それを好むでしょう。 VBAが唯一の解決策であれば、明らかにそれは大丈夫だろう。

私はhereというコードに基づいてVBAを試しました。 （私には忍耐を持ってください、私はこれの前にコード化したことはありません）が、これを処理することは本当に遅いようです。私がマクロを実行するたびに、これを計算するのに15秒以上かかりますが、私が現在持っているタスクはわずか200です。以下は、完了したすべてのタスクを取得するためのものです。私は簡単にCをIまたはNに変更することで他のものを作ることができました。ヘッダーを含めてシート全体が削除されたという別の問題があったので、範囲を明確にする必要がありました。すでにこのを通じて読んで、私はあなたの提案を楽しみにしているため

Sub ExtractList() 

Dim ws As Worksheet 
Dim destinationWorksheet As Worksheet 
Dim columnD As Range 
Dim c As Range 
Dim count As Long 

Set destinationWorksheet = ActiveWorkbook.Worksheets("Filtering") 

destinationWorksheet.Cells.ClearContents 

count = 1 
For Each ws In ActiveWorkbook.Worksheets 

    If ws.Name = "Sh1" Or ws.Name = "Sh2" Or ws.Name = "Sh3" Or ws.Name 
    = "Sh4" Or ws.Name = "Sh5" Or ws.Name = "Sh6" Or ws.Name = "Sh7" Or 
    ws.Name = "Sh8" Then 

     Set columnD = ws.Range("D:D") 'columnD 
     For Each c In columnD 

      If WorksheetFunction.IsText(c.Value) Then 
       If InStr(c.Value, "C") > 0 Then 
        c.EntireRow.Copy 
        destinationWorksheet.Cells(count, 1).PasteSpecial xlPasteValuesAndNumberFormats 
        count = count + 1 
       End If 
      End If 
     Next c 

    End If 

Next ws 

End Sub 

感謝。あなたが列全体をループしているため

乾杯、 バート

Answer 1

は、あなたのコードが実行される時間がかかりすぎる理由があります。あなたは作業範囲を区切る必要があります。

この溶液：

•ユーザが「フィルタリング」ワークシート（ターゲット）内のセルD4を用いて抽出条件を決定することを可能にする

•は、各ワークシートのデータの範囲を設定し、[SH1、Sh2を、Sh3と、 SH4、SH5、SH6、SH7、SH8]（出典）

•必要なデータと

•記事「フィルタリング」workshe内のすべてのワークシートからの結果の範囲を選択するAutoFilterを使用しますら

それはことを前提としています。同じ構造とヘッダを持って関わるすべてのワークシート•

ヘッダがソース・ワークシートのターゲットワークシートの A6:K6と A3:K3（必要に応じて変化する）

Sub ExtractList() 
Dim wshTrg As Worksheet, wshSrc As Worksheet 
Dim sCriteria As String 
Dim rDta As Range 
Dim rTmp As Range, rArea As Range, lRow As Long 

    Rem Set Worksheet Target 
    Set wshTrg = ThisWorkbook.Worksheets("Filtering") 'change as required 

    Rem Clear prior data 'Header at row 6 & data starts at row 7 - change as required 
    With wshTrg 
     Rem Sets Criteria from Cell [D4] in target worksheet 
     sCriteria = .Cells(4, 4).Value2 
     .Cells(7, 1).Value = "X" 'To set range incase there is only headers 
     .Range(.Cells(7, 1), .UsedRange.SpecialCells(xlCellTypeLastCell)).ClearContents 
    End With 

    Rem Process each worksheet 
    lRow = 7 
    For Each wshSrc In ThisWorkbook.Worksheets 
     Select Case wshSrc.Name 
     Case "Sh1", "Sh2", "Sh3", "Sh4", "Sh5", "Sh6", "Sh7", "Sh8" 
      With wshSrc 
       Rem Clear AutoFilter 
       If Not (.AutoFilter Is Nothing) Then .Cells(1).AutoFilter 
       Rem Set Data Range 
       Set rDta = .Range(.Cells(3, 1), .Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row, 11)) 
      End With 

      With rDta 
       Rem Apply AutoFilter 
       .AutoFilter Field:=4, Criteria1:=sCriteria 
       Rem Set resulting range 
       Set rTmp = .Offset(1).Resize(-1 + .Rows.count).SpecialCells(xlCellTypeVisible) 
       Rem Clear Autofilter 
       .AutoFilter 
      End With 

      Rem Post Resulting range in target worksheet 
      For Each rArea In rTmp.Areas 
       With rArea 
        wshTrg.Cells(lRow, 1).Resize(.Rows.count, .Columns.count).Value = .Value2 
        lRow = lRow + .Rows.count 

    End With: Next: End Select: Next 
    End Sub 

に位置しています

使用リソースの詳細については、次のページをお読みください：

Range Object (Excel)、Range.Offset Property (Excel)、 Range.SpecialCells Method (Excel)、

Select Case Statement、Worksheet.AutoFilter Property (Excel)、

Worksheet.AutoFilterMode Property (Excel)、With Statement