问题场景
| 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）进行进一步筛选并复制数据。
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
- 接受工作表名称、列名称、以及两个筛选值作为参数。
- 在指定的工作表上执行筛选操作。
- 对筛选后的数据，按国家分类，将指定类别（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总结
寻找最佳的方案中》》》