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 Worksheet
    Dim filterColumn As Long
    Dim lastRow As Long
    Dim i As Long
    
    ' 尝试访问工作表
    On Error Resume Next
    Set ws = ThisWorkbook.Worksheets(sheetName)
    On Error GoTo 0
    
    If ws Is Nothing Then
        MsgBox "工作表 '" & sheetName & "' 不存在。", vbExclamation
        Exit Function
    End If
    
    ' 找到筛选判断列
    filterColumn = 0
    For i = 1 To ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
        If ws.Cells(1, i).Value = columnName Then
            filterColumn = i
            Exit For
        End If
    Next i
    
    If filterColumn = 0 Then
        MsgBox "列 '" & columnName & "' 没有找到。", vbExclamation
        Exit Function
    End If
    
    ' 清除现有筛选
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    ' 应用筛选
    ws.Range("A1").AutoFilter Field:=filterColumn, Criteria1:=name1
    ws.Range("A1").AutoFilter Field:=filterColumn, Criteria2:=name2
    
    ' 复制数据
    lastRow = ws.Cells(ws.Rows.Count, filterColumn).End(xlUp).Row
    For i = 2 To lastRow
        If ws.AutoFilter.Range.Rows(i).Hidden = False Then
            If ws.Cells(i, filterColumn).Value = name1 Then
                ' 找到产地并复制数据
                Select Case ws.Cells(i, "A").Value
                    Case "US", "HK", "CN"
                        ' 复制C列以后的数据到Banana对应行
                        ws.Cells(i, "C").Resize(1, ws.Columns.Count - 3).Copy
                        For j = 2 To lastRow
                            If ws.Cells(j, filterColumn).Value = name2 And ws.Cells(j, "A").Value = ws.Cells(i, "A").Value Then
                                ws.Cells(j, "C").PasteSpecial Paste:=xlPasteValues
                            End If
                        Next j
                End Select
            End If
        End If
    Next i
    
    ' 关闭筛选
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    MsgBox "数据复制完成。"
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 Worksheet
    Dim lastRow As Long, i As Long
    Dim countryCol As Integer, classCol As Integer, col As Integer
    Dim dataRange As Range, cell As Range
    Dim country As String
    Dim dict As Object
    Set 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).Column
        If ws.Cells(1, i).Value = "Country" Then
            countryCol = i
        ElseIf ws.Cells(1, i).Value = columnName Then
            classCol = i
        End If
    Next i
    
    ' 遍历所有行
    For i = 2 To lastRow
        If (ws.Cells(i, classCol).Value = value1 Or ws.Cells(i, classCol).Value = value2) Then
            country = ws.Cells(i, countryCol).Value
            If Not dict.Exists(country) Then
                Set dict(country) = New Collection
            End If
            dict(country).Add i
        End If
    Next i
    
    ' 复制数值
    For Each key In dict.Keys
        Dim appleRow As Long
        Dim bananaRow As Long
        For Each idx In dict(key)
            If ws.Cells(idx, classCol).Value = "Apple" Then appleRow = idx
            If ws.Cells(idx, classCol).Value = "Banana" Then bananaRow = idx
        Next
        For col = 3 To ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
            ws.Cells(bananaRow, col).Value = ws.Cells(appleRow, col).Value
        Next col
    Next
    
    MsgBox "数据已经根据指定的规则复制完成。"
End Sub

---

总结

寻找最佳的方案中》》》