excel - 使用 VBA 循环遍历不同的范围并比较部分字符串
问题描述
我遇到的问题如下。我正在尝试根据众多标准将“价格和日期”从导入页面剪切到新表中。我有一个规格表,我比较这些标准必须是什么。
在导入页面上,我首先必须满足 3 个标准(这些更改基于用户输入:
这些与如下所示的表进行比较:(此表没有太大变化。最多可能会更新 Origin 和 Key,或者可能会添加另一行)
对于水果、类型和颜色匹配的每一行,我们都必须考虑另一个因素。水果是从“超市”还是“农夫”购买的。在导入表上,我们有下表,每个月都会更改。
在超市购买水果时,我想使用与满足“水果”、“类型”和“颜色”正确标准的行相对应的正确键。所以在上面的这个例子中,我想使用与“Apple”、“Fresh”、“Red”对应的键。在此示例中,这只是第一行。对应的键是“Supermarket ID 1”,我们在导入表中有几行数据。我想将这些行中的“价格”和“日期”剪切并粘贴到一个新表中。
对于从农民那里购买的水果,情况略有不同,因为 1)可比较的键与超市一列在不同的列中,并且 2)键只是导入页面的整个字符串的一部分(总是如此) . 在这里,我也想将“价格”和“日期”切成不同的表格。
希望有人理解这个问题。到目前为止,我编写的代码如下:
Sub Fruits1()
Dim Criteria1 As Variant, Criteria2 As Variant, Criteria3 As Variant, Criteria4 As Variant, Criteria5 As Variant
Dim rng As Range, cell As Range
Dim wsImport As Worksheet: Set wsImport = Sheets("Import")
Dim wsSpec As Worksheet: Set wsSpec = Sheets("Specificaties")
Dim primarykey As String, comparingkey As String
Criteria1 = wsImport.Range("C3")
Criteria2 = wsImport.Range("C4")
Criteria3 = wsImport.Range("C5")
Set rng = wsSpec.Range("H3:H" & (wsSpec.Cells(Rows.Count, 8).End(xlUp).Row))
For Each cell In rng
If cell.Value = Criteria1 And cell.Offset(0, 1).Value = Criteria2 And cell.Offset(0, 2).Value = Criteria3 Then
If cell.Offset(0, 3) = "Supermarket" Then
import_lastrow = wsImport.Range("E" & Rows.Count).End(xlUp).Row
For i = import_lastrow To 2 Step -1
primarykey = cell.Offset(0, 4).Value
comparingkey = wsImport.Cells(i, 13).Value
If InStr(primarykey, comparingkey) > 0 Then
MsgBox "cut Price and Data into new table"
End If
Next i
ElseIf cell.Offset(0, 4) = "Farmer" Then
For i = import_lastrow To 2 Step -1
primarykey = cell.Offset(0, 4).Value
comparingkey = wsImport.Cells(i, 8).Value
If InStr(primarykey, comparingkey) > 0 Then
MsgBox "cut Price and Data into new table"
End If
Next i
End If
End If
Next cell
End Sub
我相信的问题在于我试图遍历不同的范围并且做得不对。
解决方案
逻辑:
- 使用.Find 和 .Findnext搜索第一个条件。它比遍历每个单元格并匹配第一个条件要快得多
- 一旦你有你的“超市/农民”,在相关列上使用自动过滤器来识别和复制相关行。
- 复制后,删除不必要的列(如果您愿意)
代码:
好的,这是您正在尝试的吗?(未经测试)。我很快就写了这个。如果您有任何错误,请告诉我?
Option Explicit
Dim wsImport As Worksheet
Sub Sample()
Dim wsSpec As Worksheet
Set wsImport = ThisWorkbook.Sheets("Import")
Set wsSpec = ThisWorkbook.Sheets("Specificaties")
Dim CriteriaA As String, CriteriaB As String, CriteriaC As String
Dim aCell As Range, bCell As Range
Dim origin As String, KeyToFind As String
With wsSpec
CriteriaA = .Range("C3").Value2
CriteriaB = .Range("C4").Value2
CriteriaC = .Range("C5").Value2
'~~> Using .Find to look for CriteriaA
Set aCell = .Columns(8).Find(What:=CriteriaA, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'~~> Check if found or not
If Not aCell Is Nothing Then
Set bCell = aCell
'~~> Secondary checks
If aCell.Offset(, 1).Value2 = CriteriaB And _
aCell.Offset(, 2).Value2 = CriteriaC Then '<~~ If match found
'~~> Get the origin and the key
origin = aCell.Offset(, 3).Value2
KeyToFind = aCell.Offset(, 4).Value2
Else '<~~ If match not found then search for next match
Do
Set aCell = .Columns(8).FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
If aCell.Offset(, 1).Value2 = CriteriaB And _
aCell.Offset(, 2).Value2 = CriteriaC Then
origin = aCell.Offset(, 3).Value2
KeyToFind = aCell.Offset(, 4).Value2
Exit Do
End If
Else
Exit Do
End If
Loop
End If
'~~> Check the origin
If origin = "Supermarket" Then
CopyRows "F", KeyToFind, False
ElseIf origin = "Farmer" Then
CopyRows "H", KeyToFind, True
Else
MsgBox "Please check origin. Supermarket/Farmer not found. Exiting..."
End If
Else
MsgBox "Criteria A match was not found. Exiting..."
End If
End With
End Sub
'~~> Autofilter and copy filtered data
Private Sub CopyRows(Col As String, SearchString As String, PartialString As Boolean)
Dim copyFrom As Range
Dim lRow As Long
With wsImport
'~~> Remove any filters
.AutoFilterMode = False
lRow = .Range(Col & .Rows.Count).End(xlUp).Row
With .Range(Col & "1:" & Col & lRow)
If PartialString = False Then
.AutoFilter Field:=1, Criteria1:=SearchString
Else
.AutoFilter Field:=1, Criteria1:="=*" & SearchString & "*"
End If
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
'~~> Some sheet where you want to paste the output
Dim SomeSheet As Worksheet
Set SomeSheet = ThisWorkbook.Sheets("Output")
If Not copyFrom Is Nothing Then
'~~> Copy and paste to some sheet
copyFrom.Copy SomeSheet.Rows(1)
'After copying, delete the unwanted columns (OPTIONAL)
End If
End Sub
推荐阅读
- python - 如何使用 Google Cloud 作业云调度程序/使用 AppEngine 的 cron 作业设置 Python 脚本以每天运行多个小时?
- python - 为什么 append() 在 Python 中的函数完成后运行?
- python - 如何添加允许用户播放自己的音乐的 Tkinter 按钮?
- exchangewebservices - 使用 Ews 获取 PidLidEndRecurrenceDate 值
- python - 保存透明图片
- asp.net - 在 ASP.NET MVC 中计算从生日到当前日期的年龄
- mysql - 从数据库的第一个日期到今天获取数据
- yaml - 在招摇中用键值对记录下拉菜单
- php - 这是我的 php 编码中重复的按钮
- java - 使用数字和 (*) 在 Java 中绘制图案