在 VBA 中，通过将多个条件"和"以及"或"条件分组将它们循环在一起？

Question

我正在尝试构建一个代码，以便从我的数据文件中同时检查两个条件。目前，我的脚本运行良好，因为它只检查A列上的品牌名称。然而，我也想检查B列上的类别，无论是"Sun"还是"Vista"。从结构上讲，我想要这样的东西：

For i = 2 to Last_row
If Cells(i,1).value = "BananaRepublic" and Cells(i, 2).value = "Sun" or "Vista" then,
Row(i).Copy
Worksheet(new_worksheet).Paste

请注意：我平均需要在这个列表中输入30多个不同的品牌，这些品牌需要与B列(Sun/Vista(上的值相匹配，然后我需要为20个不同的宏复制这一点，每个宏用于不同的品牌名称和Sun/Optical类别组合。单独做似乎效率很低。有更好的解决方案吗？

以下是我迄今为止所做的：

Option Compare Text
Sub StarOptical()
'Define all variables
Dim customer_name As String
Dim sheetName As String
sName = ActiveSheet.Name
'ActiveWorkbook.Worksheets(sName).Sort.SortFields.Clear
'Enter the Customer Name here
customer_name = "StarOptical"
Sheets.Add.Name = customer_name
'Copy same header to the new worksheet
Worksheets(sName).Rows(1).Copy
Worksheets(customer_name).Cells(1, 1).Select
ActiveSheet.Paste
'Find the last row of the report
last_row = Worksheets(sName).Cells(Rows.Count, 1).End(xlUp).Row

'Start the loop and scan through each row for listed brands
For i = 2 To last_row
'Update the names of the approved brands in the line below
If Worksheets(sName).Cells(i, 1).Value = "ADENSCO" Or Worksheets(sName).Cells(i, 1).Value = "BANANAREPUBLI" Or Worksheets(sName).Cells(i, 1).Value = "BOSS(HUB)" Then
Worksheets(sName).Rows(i).Copy
Worksheets(customer_name).Activate
last_row_new = Worksheets(customer_name).Cells(Rows.Count, 1).End(xlUp).Row
Worksheets(customer_name).Cells(last_row_new + 1, 1).Select
ActiveSheet.Paste
End If
Next
Application.CutCopyMode = False
Worksheets(customer_name).Cells(1, 1).Select

End Sub

Answer 1

您可以这样做：

Sub tester()
CreateSheet "BananaRepublic", Array("Sun", "Vista")
'etc for other sheets
End Sub

Sub CreateSheet(sBrand As String, arrVals)
Dim wsSrc As Worksheet, wsDest As Worksheet, i As Long, c As Range
Set wsSrc = ActiveSheet
Set wsDest = wsSrc.Parent.Sheets.Add()
wsDest.Name = sBrand
wsSrc.Rows(1).Copy wsDest.Cells(1, 1)
Set c = wsDest.Cells(2, 1)
For i = 2 To wsSrc.Cells(Rows.Count, 1).End(xlUp).Row
'match on ColA?
If wsSrc.Cells(i, 1).Value = sBrand Then
'match on colB ?
If Not IsError(Application.Match(wsSrc.Cells(i, 2).Value, arrVals, 0)) Then
wsSrc.Rows(i).Copy c     'copy the row
Set c = c.Offset(1, 0)   'next cell down for copy destination
End If
End If
Next
End Sub