如何根据过滤器循环复制/粘贴代码？

Question

我需要发送每日更新，这给我带来了很多麻烦，所以我尝试将其自动化。我有一个数据集，其中客户归属于不同的卖家，我基本上需要过滤每个卖家的列表（有 60 多个，并且定期增长），并通过电子邮件将列表发送给每个人。

我已经设法根据工作表创建复制粘贴宏，并设法根据卖家列表（在单独的工作表上）过滤客户数据集，并自动将列表复制/粘贴到电子邮件选项卡，但我只能'似乎没有循环过滤器，因此它会自动对所有 60 多个卖家执行相同的操作。我可以复制这些行并更改过滤器的范围，但这似乎有点返工，因为新卖家来了，有些人定期去（每次有人来/去时，我都必须更改代码中的范围）。

Sub copy_paste()
 
 
Set object_outlook = CreateObject("Outlook.Application")
Set Email = objeto_outlook.createitem(0)

'this spreadsheet is the dataset, a pivot table that i need to filter manually to have a daily presentation with graphs, so I can't really change anything from it
Dim lRow As Long
Dim sht As Worksheet
Set sht = Sheets("PivotDataset")
Dim a As String

'the destination sheet is a temporary copy of the dataset that I use to filter
Dim lRowDestinationTable As Long
Dim DestinationSheet As Worksheet
Set DestinationSheet = Sheets("DatasetCopy")
 
'the Email Sheet is the final one that is copied and transformed into HTML
Dim lRowEmailSheet As Long
Dim EmailSheet As Worksheet
Set EmailSheet = Sheets("sendSheet")
 
lRow = sht.Cells(sht.Rows.Count, 2).End(xlUp).Row
lRowDestinationTable = DestinationSheet.Cells(dest.Rows.Count, 2).End(xlUp).Row
a = Sheets("SellersList").Range("A2").Value
 
sht.Range("B21:F" & lRow).Copy
 
With Sheets("DatasetCopy")
    .Range("A2").PasteSpecial xlPasteFormats
    .Range("A2").PasteSpecial xlPasteValues

'this is the filter I need to turn dynamic, it only filters the first seller on the list so far, and I haven't found any other filter that works
        ActiveSheet.ListObjects("CopyTable").Range.AutoFilter Field:=1, Criteria1:=a
End With
 
    DestinationSheet.Range("A2:E99999").SpecialCells(xlCellTypeVisible).Copy
 
With Sheets("sendSheet")
   .Range("A2").PasteSpecial xlPasteFormats
   .Range("A2").PasteSpecial xlPasteValues
lRowEmailSheet = EmailSheet.Cells(EmailSheet.Rows.Count, 2).End(xlUp).Row
 
'This part opens the e-mail tab and inserts the filtered clients table + any other text I want
Email.display
Email.to = Sheets("PivotDataset").Cells(4, 3).Value
Email.Subject = "Clients list"
text1 = "Hi, " & seller's name & "!"
Email.htmlbody = texto1 & "<br><br>" & rangetohtml(sendSheet.Range("B1:E" & lRowEmailSheet)) & Email.htmlbody

End With
 
On Error Resume Next
 
End Sub

由于每个卖家都有不同的客户列表，因此表字段是动态的，这部分我是对的。我还有一个功能，可以将 excel 数据表转换为 HTML，然后将其插入到电子邮件中，而且效果也很好

有什么方法可以循环复制/粘贴命令和过滤器，以便它自动过滤表吗？它是一个常规的命名表，而不是数据透视表，因此过滤方法可能不是最好的，但这是我可以收集的...

Answer 1

恭喜您已经走到这一步了。我也是这样开始了我的编程之旅！

a = Sheets("SellersList").Range("A2").Value
...
ActiveSheet.ListObjects("CopyTable").Range.AutoFilter Field:=1, Criteria1:=a

您的代码在此决定要过滤的值。您可以通过硬编码

a

的值来自行验证，看看它是否生成正确的结果：

a = "another name"
...
ActiveSheet.ListObjects("CopyTable").Range.AutoFilter Field:=1, Criteria1:=a

---

如果上述有效，这就是您所需要的：

首先，您需要一个唯一的卖家列表，以便您可以将它们单独应用于过滤器。您可以使用 Range.AdvancedFilter 过滤 A 列中的

unique

值，然后将可见单元格复制到工作表上。

接下来，您需要一个 For 循环 或 For Each 循环 为每次迭代设置不同的

a

值。

我看到你已经掌握了LastRow“技巧”，所以你也可以做同样的事情：

Dim LR as long
Dim i as long

LR = ThisWorkbook.Sheets("PastedUnique").Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 to LR
    a = Sheets("SellersList").Range("A" & i).Value
    ....
    ActiveSheet.ListObjects("CopyTable").Range.AutoFilter Field:=1, 
    Criteria1:=a
    ... ' whatever email code
    ... ' whatever clean up code before starting the next iteration. eg. clear filter
Next i

---

距上次写vba已经有十多年了，如果代码不能直接运行，请见谅。 FWIW，有更好的方法可以做到这一点，我相信当您更多地修改 VBA 时您会找到答案。目前，这是最容易执行的。