Question

下面的代码显示了如何过滤某些范围取决于列的值。每当我尝试第二种情况和第三种情况时，我都会收到运行时错误。

嗨Jeeped，请仔细阅读以下编辑过的代码：

Private Sub cmdATSend_Click()
'**************************************************************
'Copy Data
'**************************************************************

Dim myProject As String, sCriteria As String

myProject = InputBox("On what sheet do you wish to transfer these data?", "Daily Alarms Tracker", "ONO, INFINITY, or NET Brazil?")

With Sheets("Daily Alarms Tracker")

    sCriteria = vbNullString
    Select Case myProject

        Case "INFINITY", "infinity", "Infinity", "inf", "Inf"
            sCriteria = "INFINITY"
        Case "ONO", "Ono", "ono"
            sCriteria = "ONO"
        Case "NET Brazil", "NET", "net brazil", "net", "Net Brazil", "NET BRAZIL"
            sCriteria = "NET Brazil"
    End Select

    If CBool(Len(sCriteria)) Then
        With .Range("C7:K18")
            .AutoFilter
            .AutoFilter Field:=1, Criteria1:=sCriteria
            '.Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Select
            If CBool(Application.Subtotal(103, .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count))) Then
                .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1).Copy
            Else
                Debug.Print "nothing matches"
            End If
        End With
    End If
End With

'*******************************************************************
'Paste Data
'*******************************************************************

   Dim atwb As Workbook

   Set atwb = Workbooks.Open("https://ts.company.com/sites/folder1/folder2/01%20Project%20Documentations/Daily%20Alarms%20Tracker/Daily_Alarms_Tracker.xlsx")
   Set atwb = ActiveWorkbook

   Select Case sCriteria

        Case "INFINITY"
            Dim iRow As Long

                With Sheets("INFINITY")
                    eRow = .Cells(Rows.Count, "B:B").End(xlUp).Row + 1
                    .Cells(iRow, "A").PasteSpecial xlPasteValuesAndNumberFormats
                End With

        Case "ONO"
            Dim oRow As Long

                With Sheets("ONO")
                    eRow = .Cells(Rows.Count, "B:B").End(xlUp).Row + 1
                    .Cells(oRow, "A").PasteSpecial xlPasteValuesAndNumberFormats
                End With

        Case "NET"
            Dim nRow As Long

                With Sheets("NET")
                    eRow = .Cells(Rows.Count, "B:B").End(xlUp).Row + 1
                    .Cells(nRow, "A").PasteSpecial xlPasteValuesAndNumberFormats
                End With

    End Select

 End Sub

Answer 1

我添加了一个变量来存储来自Select Case的条件，并且只有在有过滤记录时才将值复制到剪贴板。过滤行上的.Copy只会复制可见行。

Private Sub cmdATSend_Click()
    Dim myProject As String, sCriteria As String, sTargetWS As String
    Dim wb As Workbook, atWB As Workbook

    myProject = InputBox("On what sheet do you wish to transfer these data?", "Daily Alarms Tracker", "ONO, INFINITY, or NET Brazil?")

    'open the target wb now for direct use later
    Set wb = ActiveWorkbook
    Set atWB = Workbooks.Open("https://ts.company.com/sites/folder1/folder2/01%20Project%20Documentations/Daily%20Alarms%20Tracker/Daily_Alarms_Tracker.xlsx")

    With wb.Sheets("Daily Alarms Tracker")

        sCriteria = vbNullString: sTargetWS = vbNullString
        Select Case myProject

            Case "INFINITY", "infinity", "Infinity", "inf", "Inf"
                sCriteria = "INFINITY"
                sTargetWS = "INFINITY"
            Case "ONO", "Ono", "ono"
                sCriteria = "ONO"
                sTargetWS = "ONO"
            Case "NET Brazil", "NET", "net brazil", "net", "Net Brazil", "NET BRAZIL"
                sCriteria = "NET Brazil"
                sTargetWS = "NET"
        End Select

        If CBool(Len(sCriteria)) Then
            With .Range("C7:k18")
                .AutoFilter
                .AutoFilter Field:=1, Criteria1:=sCriteria
                'with .offset(1,0).resize(.rows.count-1, .columns.count)
                If CBool(Application.Subtotal(103, .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count))) Then
                    .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1).Copy _
                      Destination:=atWB.Sheets(sTargetWS).Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
                Else
                    Debug.Print "nothing matches"
                End If
            End With
        End If
    End With

    'you could close the Daily_Alarms_Tracker workbook here
    'atWB.Close savechanges:=True

    Set atWB = Nothing
    Set wb = Nothing

 End Sub

我不确定您要对这些值做什么，但在此私有子的末尾可能会有行复制到剪贴板。在没有记录的情况下进行一些错误控制可能是合适的。似乎 sCriteria 保存目标工作表的名称。

运行时错误'1004'找不到单元格错误

1 个答案: