複数のForEachとWithループを1つの動作にクリーンアップ

Question

私のニーズに合った検索結果が得られず、言葉の使い方や用語と関係があると思います。私は基本的に正しい場所を探したり場所へのリンクを探して、次に行くべき方向を見つけます。 （誰かがコードをダンプするだけではなく、ここで学んでいます...）。

複数の「For Each」ループと「With」ループを1つのアクションに組み合わせて、オーバーヘッド/処理時間を節約したいと考えています。

現在、私はメイン 'データダンプシート'からデータを取り出し、必要なローカラムを 'カラムスクラブ'シートにコピーします。 'ColScrub'シートから、（少なくとも）3つの別々の 'For Each'ループを使用して、必要なフィルタリングされたデータを取得します。これまでに20 +秒の遅延があります私が今持っているデータやプル/プルーブは、今後の展開を制限しています。

基本的な説明は、私が 'ColScrub'シートから読んでいることです。私は新しいTempシートを作成し、フィルタリングしたデータをTemp1に貼​​り付けます。

その後、Temp1と 'For Each'からもう一度読み込んで、追加のフィルタ処理されたデータを新しいTemp2シートに貼り付けます。

最後に、Temp2から読み込み、もう1つの 'For Each'ループを使用して、データをさらにフィルターしてからTemp3に貼り付けます。

Temp3は基本的に私が必要とする「クリーンデータ」を持っており、そこから他のvbaや式を実行して、そのクリーンデータから表現可能なデータを与えます。

人口TempSheet3へのデータ・ダンプ・シート "から取得するためのコードスニペット：理想的

Sub CopyRowDataToDiffSheets() 
Dim LastRowFromColScrubE As Integer 
Dim LastRowFromTemp1 As Integer 
Dim LastRowFromTemp2 As Integer 
Dim LastRowFromTemp3 As Integer 
Dim x As Integer 
Dim c1 As Range 
Dim sName1 As String 
Dim sName2 As String 
Dim sName3 As String 
sName1 = "Temp1" 
sName2 = "Temp2" 
sName3 = "Temp3" 
Application.ScreenUpdating = False 
Application.DisplayAlerts = False 


'''''''''''''''''Copy filter data to TempSheet1 
Worksheets.Add().Name = sName1 'make Sheet Temp1 
LastRowFromColScrubE = Sheets("ColScrub").Range("E" &  Rows.Count).End(xlUp).Row: x = 1 'count items in col E 
For Each c1 In Sheets("ColScrub").Range("E1:E" & LastRowFromColScrubE) 'However many rows are in ColE on ColScrub sheet, set C1 counter as its index 
If c1.Value = "In-Progress" Or c1.Value = "Jeopardy" Then 'Add value to index if InProg/Jeo are found in colE 
c1.EntireRow.Copy Worksheets("Temp1").Range("A" & x) 'paste date from ColScrub to Sheet Temp1 
     x = x + 1 
    End If 
Next c1 


'''''''''''''''''Copy filter data to TempSheet2 
Worksheets.Add().Name = sName2 
LastRowFromTemp1 = Sheets("Temp1").Range("D" & Rows.Count).End(xlUp).Row: x = 1 
For Each c1 In Sheets("Temp1").Range("D1:D" & LastRowFromTemp1) 
    If c1.Value = "New Connect" Then 
     c1.EntireRow.Copy Worksheets("Temp2").Range("A" & x) 
     x = x + 1 
    End If 
Next c1 


'''''''''''''''''Copy filter data to TempSheet3 
Worksheets.Add().Name = sName3 
LastRowFromTemp2 = Sheets("Temp2").Range("F" & Rows.Count).End(xlUp).Row: x = 1 
For Each c1 In Sheets("Temp2").Range("F1:F" & LastRowFromTemp2) 
    If c1.Value = "New Connect" Or c1.Value = "Change" Then 
     c1.EntireRow.Copy Worksheets("Temp3").Range("A" & x) 
     x = x + 1 
    End If 
Next c1 

    '[et el] 

、私はちょうどColScrubシート上に、私はすでに行うことができますいくつかの特定の列を（コピーしたいです）、その列のデータから、 '進行中'または '危険'状態の項目だけでなく、 'New Connect'ステータスの項目と 'NewConnect'の項目のColF、または 'NewConnect' 'ステータスを変更する。

私はコール/コールド/ ColFはすべて（テキストなどの日付範囲のColAAとコラボのようにフィルタリングするために、物事を追加し、可能な）一歩であることにフィルタを得ることができる方法はあり

その場合は理にかなっている。

次に、私はフィルタリングに関するいくつかのものを見つけましたが、これは下にありますが、私は（またはどのように）このフィルタコードを使用して元の 'データダンプシート' ColScrub/Sheet1/Sheet2/Sheet3の作成と操作を行い、必要な正確なカラムデータと条件にフィルタをかけるだけです。

Sub test() 
Dim CountLV_Rows As Long 
Dim wbActive As Excel.Workbook 

Set wbActive = ActiveWorkbook 
With wbActive 
.Sheets("Temp Data").Range("A:T").ClearContents 
CountLV_Rows = .Sheets("Main Sheet").Range("A" & Rows.Count).End(xlUp).Row 
.Sheets("Main Sheet").Range("A1", "T" & CountLV_Rows).Copy _ 
     Destination:=.Sheets("Temp Data").Range("A1", "T" & CountLV_Rows) 
With .Sheets("Temp Data") 
    .Range("A1", "T" & CountLV_Rows).Sort Key1:=.Range("R1"), Order1:=xlAscending, Header:=xlGuess, _ 
              OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ 
              DataOption1:=xlSortNormal 
.Activate 
MsgBox "Sorted by R" 
    .Range("A1", "T" & CountLV_Rows).Sort Key1:=.Range("C1"), Order1:=xlAscending, Header:=xlGuess, _ 
              OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ 
              DataOption1:=xlSortNormal 
End With 
End With 
End Sub 

私はそれが今日立っているように私のコード内で作業するために、上記を得たが、それは列

Answer 1

でソート以外の何かをしhtinkしていないが編集：ここでテストコード

Option Explicit 

Sub main() 
Dim dataRng As Range 

With Sheets("ColScrub") 
    .Rows(1).Insert 'temporary "header" row to allow for subsequent Autofilter operations 

    Set dataRng = Range(Cells(1, 1), .Cells(2, 1).CurrentRegion) 
    With dataRng 
     .Rows(1).value = "temp header" ' assign temporary headers. no matter they actual value, since autofilter will use columns index 
     .AutoFilter field:=5, Criteria1:="In Progress", Operator:=xlOr, Criteria2:="Jeopardy" 
     .AutoFilter field:=4, Criteria1:="New Connect" 
     .AutoFilter field:=6, Criteria1:="New Connect", Operator:=xlOr, Criteria2:="Change" 

     If Application.WorksheetFunction.Subtotal(103, .Columns("A")) > 1 Then .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Copy Destination:=Worksheets("Temp1").Range("A1") 

     .AutoFilter 'remove filters 
    End With 
    .Rows(1).Delete 'remove temporary "header" row 

End With 

End Sub 

を次の