Microsoft VBA Excel VBA学习笔记——双重筛选+复制数值1.0

问题场景

Country	Product	CLASS 1	CLASS 2	CLASS 3	CLASS 4	CLASS 5	CLASS 6	…
US	Apple	0.364141603	0.891821061	0.059145199	0.732011029	0.050963656	0.222464259	…
US	Banana	0.230083333	0.402726218	0.154883667	0.298890486	0.780232621	0.028592635	…
CN	Apple	0.776237047	0.507554832	0.481978786	0.964094710	0.635608483	0.650148065	…
CN	Banana	0.314416117	0.865829827	0.838746225	0.584803658	0.632143938	0.635900146	…
HK	Apple	0.038955013	0.537686547	0.396884228	0.646283709	0.980316357	0.729927410	…
HK	Banana	0.929699567	0.875914643	0.855651289	0.349502863	0.778827116	0.056140485	…
US	Orange	0.637295510	0.966399457	0.102005751	0.345379154	0.182812383	0.255992180	…
US	Strawberry	0.937893889	0.151947906	0.234707740	0.626308424	0.804376439	0.138557531	…
CN	Orange	0.589701555	0.029821538	0.324999202	0.138480401	0.410818109	0.181386365	…
CN	Strawberry	0.587089886	0.870334801	0.050660711	0.712157225	0.946011122	0.286730440	…
HK	Orange	0.884634243	0.896100687	0.675844393	0.355247262	0.498187742	0.325255134	…
HK	Strawberry	0.697344394	0.423227932	0.650203362	0.560784327	0.298141331	0.186946272	…

简述：

其实很简单的操作，就是两次筛选后复制Item1全部数据到Item2中，两个Item有且只有一行。

草稿1

1. 打开工作表：通过工作表名称来定位和激活工作表。
2. 定位筛选判断列：在第一行中找到Product的列，然后进行筛选。
3. 筛选指定名称：首先筛选出包含 name1 “Apple”和name2“Banana”的行。
4. **再次筛选Country **：在筛选出的结果中，基于Country （US、HK、CN）进行进一步筛选并复制数据。

Function FilterAndCopyData(sheetName As String, columnName As String, name1 As String, name2 As String)Dim ws As WorksheetDim filterColumn As LongDim lastRow As LongDim i As Long' 尝试访问工作表On Error Resume NextSet ws = ThisWorkbook.Worksheets(sheetName)On Error GoTo 0If ws Is Nothing ThenMsgBox "工作表 '" & sheetName & "' 不存在。", vbExclamationExit FunctionEnd If' 找到筛选判断列filterColumn = 0For i = 1 To ws.Cells(1, ws.Columns.Count).End(xlToLeft).ColumnIf ws.Cells(1, i).Value = columnName ThenfilterColumn = iExit ForEnd IfNext iIf filterColumn = 0 ThenMsgBox "列 '" & columnName & "' 没有找到。", vbExclamationExit FunctionEnd If' 清除现有筛选If ws.AutoFilterMode Then ws.AutoFilterMode = False' 应用筛选ws.Range("A1").AutoFilter Field:=filterColumn, Criteria1:=name1ws.Range("A1").AutoFilter Field:=filterColumn, Criteria2:=name2' 复制数据lastRow = ws.Cells(ws.Rows.Count, filterColumn).End(xlUp).RowFor i = 2 To lastRowIf ws.AutoFilter.Range.Rows(i).Hidden = False ThenIf ws.Cells(i, filterColumn).Value = name1 Then' 找到产地并复制数据Select Case ws.Cells(i, "A").ValueCase "US", "HK", "CN"' 复制C列以后的数据到Banana对应行ws.Cells(i, "C").Resize(1, ws.Columns.Count - 3).CopyFor j = 2 To lastRowIf ws.Cells(j, filterColumn).Value = name2 And ws.Cells(j, "A").Value = ws.Cells(i, "A").Value Thenws.Cells(j, "C").PasteSpecial Paste:=xlPasteValuesEnd IfNext jEnd SelectEnd IfEnd IfNext i' 关闭筛选If ws.AutoFilterMode Then ws.AutoFilterMode = FalseMsgBox "数据复制完成。"
End Function

草稿2

1. 接受工作表名称、列名称、以及两个筛选值作为参数。
2. 在指定的工作表上执行筛选操作。
3. 对筛选后的数据，按国家分类，将指定类别（Apple）的数值复制到另一个类别（Banana）中。

Sub CopyValuesBasedOnClassAndCountry(wsName As String, columnName As String, value1 As String, value2 As String)Dim ws As WorksheetDim lastRow As Long, i As LongDim countryCol As Integer, classCol As Integer, col As IntegerDim dataRange As Range, cell As RangeDim country As StringDim dict As ObjectSet dict = CreateObject("Scripting.Dictionary")' 设置工作表Set ws = ThisWorkbook.Worksheets(wsName)' 确定总行数lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row' 查找国家和分类列的索引For i = 1 To ws.Cells(1, ws.Columns.Count).End(xlToLeft).ColumnIf ws.Cells(1, i).Value = "Country" ThencountryCol = iElseIf ws.Cells(1, i).Value = columnName ThenclassCol = iEnd IfNext i' 遍历所有行For i = 2 To lastRowIf (ws.Cells(i, classCol).Value = value1 Or ws.Cells(i, classCol).Value = value2) Thencountry = ws.Cells(i, countryCol).ValueIf Not dict.Exists(country) ThenSet dict(country) = New CollectionEnd Ifdict(country).Add iEnd IfNext i' 复制数值For Each key In dict.KeysDim appleRow As LongDim bananaRow As LongFor Each idx In dict(key)If ws.Cells(idx, classCol).Value = "Apple" Then appleRow = idxIf ws.Cells(idx, classCol).Value = "Banana" Then bananaRow = idxNextFor col = 3 To ws.Cells(1, ws.Columns.Count).End(xlToLeft).Columnws.Cells(bananaRow, col).Value = ws.Cells(appleRow, col).ValueNext colNextMsgBox "数据已经根据指定的规则复制完成。"
End Sub

---

总结

寻找最佳的方案中》》》