Question

VBA很新。我需要将所有付费帐号复制到当前表的A列。 “帐户”工作表在A列和B列中的帐号为“已付款”或“未付款”。我只是在出错后不断收到错误并且我不确定我是在修复它还是让它变得更糟，但我无法通过的最后一个错误是Cells(t,1).Value =i行：“应用程序定义或对象定义错误“。

Sub Button1_Click()

  Dim t As Integer
  Dim i As Range

  Dim sheet As Worksheet
  Set sheet = ActiveWorkbook.Sheets("Accounts")

  Dim rng As Range
  Set rng = Worksheets("accounts").Range("A:A")

  'starting with cell A2
  target = 2
  'For each account number in Accounts
  For Each i In rng
  'find if it's paid or not
    If Application.WorksheetFunction.VLookup(i, sheet.Range("A:B"), 2, False) = "PAID" Then
      'if so, put it in the target cell
      Cells(t, 1).Value = i
      t = t + 1
    End If
  Cells(t, 1).Value = i
  t = t + 1
  Next i

End Sub

Answer 1

以下是我刚刚创建的示例：

Sub GetPaid()

    Dim cells As Range
    Set cells = Range("A1:B10")

    Dim name As String
    Dim paid As String
    Dim insertAt As Integer
    insertAt = 1

    For Each r In cells.Rows

        name = r.cells(1, 1).Value
        paid = r.cells(1, 2).Value

        If paid = "PAID" Then
            MsgBox name & " has paid!"
            CopyToSheet "Sheet1", insertAt, name

            insertAt = insertAt + 1
        End If

    Next r

End Sub

Sub CopyToSheet(SheetName As String, InsertAtRow As Integer, Value As String)
    Sheets(SheetName).cells(InsertAtRow, 1).Value = Value
End Sub

为我的变量名称道歉！我希望这能够帮到你。：）

Answer 2

请使用自动过滤器。表格样本如下。

试试这个：

 Sub Test2()
     Dim LastRow As Long
    Sheets("current").UsedRange.Offset(0).ClearContents
       With Worksheets("Accounts")
         .Range("$B:$B").AutoFilter field:=1, Criteria1:="Paid"
         LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
         .Range("B1:B" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
          Destination:=Sheets("current").Range("A1")
      End With
End Sub

******另一个程序版本******************

这会更新＆＃34;付费状态＆＃34; 。要求帐户ID出现在当前工作表和要在“帐单”E1 Cell

中提及的条件中

下面附有代码段：

Sub Test3()
    Dim i As Long, j As Long, colStatus As Long, lastrowplus As Long, lastrowminus As Long

    colStatus = 2 'your status column number
    lastrowplus = Sheets("Accounts").Cells(Sheets("Accounts").Rows.Count, 1).End(xlUp).Row
    lastrowminus = Sheets("current").Cells(Sheets("current").Rows.Count, 1).End(xlUp).Row

    For i = 1 To lastrowplus
        For j = 1 To lastrowminus
            If Sheets("Accounts").Cells(i, 1).Value = Sheets("current").Cells(j, 1).Value Then
            If Sheets("current").Cells(j, colStatus).Value = Sheets("current").Cells(1, 4).Value Then
                Sheets("current").Cells(j, colStatus).Value = Sheets("Accounts").Cells(i, colStatus).Value
            End If
            End If
        Next j
    Next i
End Sub

******第三项计划替代方案********

此方法基于创建对象Scripting.Dictionary。对于相对简单的需求，例如仅识别列表中的不同项，从功能功能角度使用词典没有任何优势。但是，如果你必须：

- 检索密钥以及与这些密钥关联的项目; - 处理区分大小写的密钥;和/或 - 能够容纳项目和/或键的变化

然后使用Dictionary对象提供了一个引人注目的Collection集合。然而，即使对于相对简单的需求，词典也可以提供显着的性能优势。可以参考以下链接。

VBA for smarties: Dictionaries

我们必须在当前工作表中创建额外的列，该列应填充字符串＆＃34;付费＆＃34;因为需要额外的匹配标准。它可以在工作表中成为隐藏列。另请参阅Microsoft Scripting Runtime Library。数据填充在数组中。并且程序会将当前工作表上的AccountsID+Prog_status匹配到AccountID+Status字段以进行匹配。匹配键在“状态”字段中的当前工作表中更新。下面附有当前和账户表的样本图像。

代码段如下：

  Sub test2()
    Dim a, i As Long, txt As String, result
    a = Sheets("Accounts").Cells(1).CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            txt = Join(Array(a(i, 1), a(i, 2)), Chr(2))
            .Item(txt) = a(i, 2)
        Next
        a = Sheets("current").Cells(1).CurrentRegion.Value
        ReDim result(1 To UBound(a, 1) - 1, 1 To 1)
        For i = 2 To UBound(a, 1)
            txt = Join(Array(a(i, 1), a(i, 3)), Chr(2))
            result(i - 1, 1) = .Item(txt)
        Next
    End With
    Sheets("current").Range("B2").Resize(UBound(result, 1)).Value = result
End Sub

Answer 3

为什么不使用它。

 Sub Button1_Click()

        Sheets("Accounts").activate ' your first sheet
        Range("A1").select
        Range(Selection, Selection.End(xlDown)).Select ' select the first value to the last
        for each MyCell in Selection
            i = i + 1
            if MyCell.value = "PAID" then ' if the active cell has my value then
                sheets("SecondSheets").Cells(i,1).value = MyCell.Value ' throw this value to the next sheet
            end if 
        next MyCell

    end sub

希望有所帮助。

仅将付费帐号插入新表中

3 个答案: