设为首页收藏本站

开启辅助访问

Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › VBA 代码求助

数据透视表40+个常用小技巧，让你一次学会！

发新帖

查看: 1879|回复: 7

[已解决]VBA 代码求助

发表于 2012-10-10 15:40 | 显示全部楼层 |阅读模式

工作中常用的Excel函数公式，全印在一张超大鼠标垫上

问题描述：现有左右两列（F列、G列）数据，想通过代码实现，左右两列数据相等的行，用颜色标记出来。例如单元格F2=G256，则第2行与256行均用绿色标记；F4=G95，则第4行与95行均用绿色标记。

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2012-10-10 16:37

Sub 比较2()
Dim dic1 As Object, dic2 As Object
Dim iRow As Long
Dim i As Long, arr, srg As String, str1 As String, str2 As String
iRow = [f1].End(xlDown).Row
arr = Range("f1:g" & iRow).Value
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
For i = 2 To iRow
If Not dic1.exists(arr(i, 1)) And arr(i, 1) <> 0 Then
dic1.Add arr(i, 1), i
End If
If Not dic2.exists(arr(i, 2)) And arr(i, 2) <> 0 Then
dic2.Add arr(i, 2), i
End If
Next
arr = dic1.keys
For i = 0 To UBound(arr)
If dic1.exists(arr(i)) And dic2.exists(arr(i)) Then
str1 = Replace(Cells(Val(dic1(arr(i))), "f").Address, "$", "") & ","
str2 = Replace(Cells(Val(dic2(arr(i))), "f").Address, "$", "") & ","
If Len(srg & str1 & str2) > 249 Then
Range(Left(srg, Len(srg) - 1)).EntireRow.Interior.ColorIndex = 35
srg = str1 & str2
Else
srg = srg & str1 & str2
End If
End If
Next
End Sub

复制代码

跳转到最佳答案楼层

11.42 KB, 下载次数: 11

excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程

回复

使用道具举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上

发表于 2012-10-10 16:04 | 显示全部楼层

工作中常用的Excel函数公式，全印在一张超大鼠标垫上

本帖最后由 hwc2ycy 于 2012-10-10 16:09 编辑

如左右列的数据重复值，是不会变色的对不？

回复

使用道具举报

楼主| 发表于 2012-10-10 16:07 | 显示全部楼层

工作中最常用的Excel函数公式，全印在一张鼠标垫上

能否录个屏看下。谢谢。

回复

使用道具举报

发表于 2012-10-10 16:24 | 显示全部楼层

本帖最后由 hwc2ycy 于 2012-10-10 16:26 编辑

Sub 比较()
Dim dic1 As Object, dic2 As Object
Dim iRow As Long
Dim i As Long, arr
iRow = [f1].End(xlDown).Row
arr = Range("f1:g" & iRow).Value
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
For i = 2 To iRow
If Not dic1.exists(arr(i, 1)) And arr(i, 1) <> 0 Then
dic1.Add arr(i, 1), i
End If
If Not dic2.exists(arr(i, 2)) And arr(i, 2) <> 0 Then
dic2.Add arr(i, 2), i
End If
Next
arr = dic1.keys
For i = 0 To UBound(arr)
If dic1.exists(arr(i)) And dic2.exists(arr(i)) Then
Cells(Val(dic1(arr(i))), "f").EntireRow.Interior.ColorIndex = 35
Cells(Val(dic2(arr(i))), "f").EntireRow.Interior.ColorIndex = 35
End If
Next
End Sub

复制代码

回复

使用道具举报

发表于 2012-10-10 16:37 | 显示全部楼层本楼为最佳答案

这个最佳答案由 hwc2ycy 给出，感谢 hwc2ycy 的回答。

单击隐藏图章

Sub 比较2()
Dim dic1 As Object, dic2 As Object
Dim iRow As Long
Dim i As Long, arr, srg As String, str1 As String, str2 As String
iRow = [f1].End(xlDown).Row
arr = Range("f1:g" & iRow).Value
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
For i = 2 To iRow
If Not dic1.exists(arr(i, 1)) And arr(i, 1) <> 0 Then
dic1.Add arr(i, 1), i
End If
If Not dic2.exists(arr(i, 2)) And arr(i, 2) <> 0 Then
dic2.Add arr(i, 2), i
End If
Next
arr = dic1.keys
For i = 0 To UBound(arr)
If dic1.exists(arr(i)) And dic2.exists(arr(i)) Then
str1 = Replace(Cells(Val(dic1(arr(i))), "f").Address, "$", "") & ","
str2 = Replace(Cells(Val(dic2(arr(i))), "f").Address, "$", "") & ","
If Len(srg & str1 & str2) > 249 Then
Range(Left(srg, Len(srg) - 1)).EntireRow.Interior.ColorIndex = 35
srg = str1 & str2
Else
srg = srg & str1 & str2
End If
End If
Next
End Sub

复制代码

回复

使用道具举报

发表于 2012-10-10 16:44 | 显示全部楼层

代码只匹配第一次相等的行。

回复

使用道具举报

发表于 2012-10-10 16:47 | 显示全部楼层

0值不匹配。

回复

使用道具举报

楼主| 发表于 2012-10-10 16:47 | 显示全部楼层

大部分已标记，还有小部分数据没有标记出来

回复

使用道具举报

发新帖

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-25 00:22 , Processed in 0.341736 second(s), 9 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表