仅将付费帐号插入新表中

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

请使用自动filter。 表格样本附在下面。

尝试这个 ：

  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 

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

这会更新“付费状态”帐户。 要求帐号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 

******第三scheme替代********

这种方法基于创build对象Scripting.Dictionary 。 对于相对简单的需求，例如仅识别列表中的不同项目，从functionfunctionangular度使用字典没有任何优势。 但是，如果您必须：

– 检索按键以及与这些按键相关的项目; – 处理大小写敏感的按键; 和/或 – 能够适应项目和/或密钥的变化

那么使用Dictionary对象为集合提供了一个引人注目的select。 但是，即使对于相对简单的需求，字典也可以提供显着的性能优势。 可能想引用下面的链接。

聪明人的VBA：字典

我们将不得不在当前表单中创build额外的列，这些列应该用string“Paid”填充，因为需要额外的匹配条件。 它可以在表单中做成一个隐藏的列。 还请设置对Microsoft脚本运行时库的引用。 数据填充在数组中。 程序运行将当前表中的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 2

这里是我刚刚创build的一个示例：

 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 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 

希望它的帮助。