Question

我没有获得符合我需求的搜索结果，我认为它与我的单词用法或术语有关。我基本上正在寻找正确的字词来搜索或链接到地方，以找到下一步的方向。（并没有人只是将代码转储下来，我在这里学习......）。

我希望将多个“For Each”和“With”循环组合成一个动作，以节省开销/处理时间。

目前，我从主数据转储表中提取数据，并将我需要的原始列复制到“列擦除”表。从'ColScrub'表单中，然后使用（至少）三个单独的'For Each'循环来将数据过滤到我需要的状态，到目前为止一直运行良好，尽管有时会有20多个延迟数据的拉/擦洗以及我现在拥有的东西现在限制了未来的扩展。

基本概述是我正在阅读'ColScrub'表格，我让它制作一个新的Temp表格，并将一些过滤后的数据粘贴到Temp1。

之后，我再次从Temp1和'For Each'读取，将额外过滤的数据粘贴到新的Temp2工作表。

最后，我从Temp2读取并使用另一个'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 Sheet上进行复制）和该列数据，然后在ColE上仅过滤“正在进行”或“危险”状态的项目，以及从ColD仅用于“New Connect”状态的项目以及ColF用于“NewConnect”或“Change”状态的项目。

有没有办法让ColE / ColD / ColF过滤器一步到位（并且可以添加过滤器，如ColAA过滤日期范围和ColAB文本等）

如果这是有道理的。

然后我发现了一些关于过滤的东西，这是下面的，但我不知道我是否可以（或我怎么可能）使用这个过滤器代码从原始的'数据转储表'中删除并跳过所有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

已编辑：此处遵循经过测试的代码

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

将多个ForEach和With循环清理为单个操作

1 个答案: