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
- 打开工作表：通过工作表名称来定位和激活工作表。
- 定位筛选判断列：在第一行中找到Product的列，然后进行筛选。
- 筛选指定名称：首先筛选出包含 name1 “Apple”和name2“Banana”的行。
- **再次筛选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
- 接受工作表名称、列名称、以及两个筛选值作为参数。
- 在指定的工作表上执行筛选操作。
- 对筛选后的数据，按国家分类，将指定类别（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
总结
寻找最佳的方案中》》》