Question

我正在尝试复制满足两个条件的单元格值：（1）突出显示的行，（2）具有特定的区域代码，例如＆＃34; WA＆＃34 ;.需要将列B中的单元格值复制到A列标题下方的目标工作表。此外，将符合这些条件的那些值对应的工作表名称复制到目标工作表。

我遇到的问题：

只要我添加此代码，它就会运行，但不会将任何值传递到目标工作表。 LCase(Cells(Cell.Row, "A").Value) = "wa"
如果我删除上面的代码行，并更改目标区域以查看第2列Set Target = .Range(.Cells(1, 2), .Cells(LastRow, 2))，它将列出B列中突出显示的值，并从A1开始粘贴它们，而不是开始在标题下面。

部分目标区域（完整目标区域具有不同的区域代码和值沿着这些列向下）：

Sub Criteria()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim wkb As Workbook
Dim Sh As Worksheet
Dim DestSh As Worksheet
Dim LastRow As Long, LastCol As Long, Last As Long
Dim Target As Range, Cell As Range, Dest As Range
Dim DestCounter As Long

' Delete the data off of AdvFilter sheet.
ActiveWorkbook.Worksheets("AdvFilter").Range("A5:F5" & Last + 1).Cells.Clear
On Error GoTo 0

'initialize destination counter
DestCounter = 1
Set DestSh = ThisWorkbook.Worksheets("AdvFilter")
For Each Sh In ThisWorkbook.Worksheets
    If ActiveSheet.Visible = True Then

    Last = fLastRow(DestSh)

    With Sh
    LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set Target = .Range(.Cells(1, 1), .Cells(LastRow, 2))
    End With

        For Each Cell In Target '<~ loop through each cell in the target space
            If AmIYellow(Cell) And Cell.Value <> "" And _
            LCase(Cells(Cell.Row, "A").Value) = "wa" Then
              Set Dest = DestSh.Cells(Last + DestCounter, 1)
              Cell.Copy Dest
              DestCounter = DestCounter + 1
            End If
        Next Cell

    End If
Next Sh
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Function fLastRow(Sh As Worksheet)
    On Error Resume Next
    LastRow = Sh.Cells.Find(What:="*", _
                            After:=Sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

Answer 1

如果您只需要数据而不需要格式化;您最好使用数组来收集数据并将一次操作中的所有数据写入目标范围。

Sub Criteria()
    Dim ws As Worksheet
    Dim r As Range
    Dim x As Long
    Dim Data
    ReDim Data(1 To 2, 1 To 1)

    With ActiveWorkbook.Worksheets("AdvFilter")
        .Range(.Range("A" & .Rows.Count).End(xlUp), "F5").Cells.Clear
    End With

    For Each ws In ThisWorkbook.Worksheets
        If ws.Visible = xlSheetVisible Then
            With ws
                For Each r In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
                    If LCase(r.Value) = "wa" And r.Interior.ColorIndex = 6 Then
                        x = x + 1
                        ReDim Preserve Data(1 To 2, 1 To x)
                        Data(1, x) = r.Offset(0, 1)
                        Data(2, x) = ws.Name

                    End If
                Next
            End With
        End If
    Next

    With ActiveWorkbook.Worksheets("AdvFilter")
        With .Range("A" & .Rows.Count).End(xlUp).Offset(1)

            If x > 0 Then .Resize(x, 2).Value = Application.Transpose(Data)

        End With
    End With
End Sub

将突出显示的单元格和图纸名称复制到目标工作表

1 个答案: