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)进行进一步筛选并复制数据。
vba 复制代码
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)中。
vba 复制代码
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

总结

寻找最佳的方案中》》》

相关推荐
葡萄城技术团队14 小时前
从100秒到10秒的性能优化,你真的掌握 Excel 的使用技巧了吗?
excel
QQ3596773452 天前
ArcGIS Pro实现基于 Excel 表格批量创建标准地理数据库(GDB)——高效数据库建库解决方案
数据库·arcgis·excel
私人珍藏库2 天前
[Windows] 微软 .Net 运行库离线安装包 | Microsoft .Net Packages AIO_v09.09.25
microsoft·.net·运行库
掘根2 天前
【CMake】List
windows·microsoft·list
小琦QI2 天前
关于电脑连接不到5g的WiFi时的一些解决办法
5g·microsoft·win
星空的资源小屋3 天前
Digital Clock 4,一款免费的个性化桌面数字时钟
stm32·单片机·嵌入式硬件·电脑·excel
I'm a winner3 天前
第七章:AI进阶之------输入与输出函数(一)
开发语言·人工智能·python·深度学习·神经网络·microsoft·机器学习
过河卒_zh15667663 天前
9.13AI简报丨哈佛医学院开源AI模型,Genspark推出AI浏览器
人工智能·算法·microsoft·aigc·算法备案·生成合成类算法备案
揭老师高效办公3 天前
在Excel和WPS表格中批量删除数据区域的批注
excel·wps表格
我是zxb3 天前
EasyExcel:快速读写Excel的工具类
数据库·oracle·excel