设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 数据的查错与替换
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 2341|回复: 7

[已解决]数据的查错与替换

[复制链接]
wucj80
发表于 2012-8-19 23:55 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
数据的查错与替换
最佳答案
月排行榜 / 总排行榜
周义坤
2012-8-20 09:26
  1. Sub ek_sky()
  2.     Dim arr, arb, i&, d As Object
  3.     Set d = CreateObject("scripting.dictionary")
  4.     arr = Range("A2:B" & Cells(Rows.Count, 1).End(xlUp).Row).Value
  5.     ReDim arb(1 To UBound(arr), 1 To 2)
  6.     For i = 1 To UBound(arr)
  7.         d(arr(i, 1)) = d(arr(i, 1)) + 1
  8.     Next i
  9.     For i = 1 To UBound(arr)
  10.         arb(i, 1) = arr(i, 1)
  11.         arb(i, 2) = WorksheetFunction.Text(d(arr(i, 1)), "[>2][dbnum1]0\通;")
  12.     Next i
  13.     Range("C2:C60000").ClearContents
  14.     Range("C2").Resize(UBound(arr), 2) = arb
  15.     For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
  16.         If Cells(i, 2) <> Cells(i, 4) Then
  17.             Range("B" & i).Interior.ColorIndex = 6
  18.             Range("C" & i).Resize(1, 2).Font.ColorIndex = 5
  19.         Else
  20.             Range("B" & i).Interior.ColorIndex = xlNone
  21.             Range("C" & i).Resize(1, 2).Font.ColorIndex = 0
  22.         End If
  23.     Next i
  24. End Sub
复制代码
数据的查错与替换.zip (17.68 KB, 下载次数: 11)

数据的查错与替换.rar

2.17 KB, 下载次数: 19
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
发表于 2012-8-20 00:18 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
提供最原始的数据
回复

使用道具 举报

6963hwh
发表于 2012-8-20 00:18 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
看看我有多少金币？
回复

使用道具 举报

发表于 2012-8-20 08:08 | 显示全部楼层
路过学习一下
回复

使用道具 举报

hwc2ycy
发表于 2012-8-20 08:47 | 显示全部楼层
既然数据是排好的，如果没重排，这样也就没有多大意义了，楼主提供原始数据吧。
回复

使用道具 举报

zjdh
发表于 2012-8-20 09:07 | 显示全部楼层
数据的查错与替换.rar (8.37 KB, 下载次数: 4)
回复

使用道具 举报

发表于 2012-8-20 09:26 | 显示全部楼层    本楼为最佳答案   
  1. Sub ek_sky()
  2.     Dim arr, arb, i&, d As Object
  3.     Set d = CreateObject("scripting.dictionary")
  4.     arr = Range("A2:B" & Cells(Rows.Count, 1).End(xlUp).Row).Value
  5.     ReDim arb(1 To UBound(arr), 1 To 2)
  6.     For i = 1 To UBound(arr)
  7.         d(arr(i, 1)) = d(arr(i, 1)) + 1
  8.     Next i
  9.     For i = 1 To UBound(arr)
  10.         arb(i, 1) = arr(i, 1)
  11.         arb(i, 2) = WorksheetFunction.Text(d(arr(i, 1)), "[>2][dbnum1]0\通;")
  12.     Next i
  13.     Range("C2:C60000").ClearContents
  14.     Range("C2").Resize(UBound(arr), 2) = arb
  15.     For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
  16.         If Cells(i, 2) <> Cells(i, 4) Then
  17.             Range("B" & i).Interior.ColorIndex = 6
  18.             Range("C" & i).Resize(1, 2).Font.ColorIndex = 5
  19.         Else
  20.             Range("B" & i).Interior.ColorIndex = xlNone
  21.             Range("C" & i).Resize(1, 2).Font.ColorIndex = 0
  22.         End If
  23.     Next i
  24. End Sub
复制代码
数据的查错与替换.zip (17.68 KB, 下载次数: 11)
回复

使用道具 举报

wucj80
 楼主| 发表于 2012-8-20 23:27 | 显示全部楼层
六楼的是二通也上,一通也上,也许在其它地方用得上,但是我现在用不上,多谢六楼这位老师了,七楼的这位老师是现在我这个数据想要的,谢谢了,学发习了
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-5-3 17:42 , Processed in 0.479903 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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