Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 1981|回复: 2

[已解决]历遍工作表对齐并着色的问题

[复制链接]
发表于 2013-11-22 08:40 | 显示全部楼层 |阅读模式
本帖最后由 E见如故 于 2013-11-22 16:23 编辑

附件 历遍工作表对齐并着色.rar (424.1 KB, 下载次数: 9)
发表于 2013-11-22 15:02 | 显示全部楼层
就近原则是什么意思,是从上到下先找到哪个用哪个,还是哪个跟A列最下面3个数最接近用哪个?
回复

使用道具 举报

发表于 2013-11-22 15:26 | 显示全部楼层    本楼为最佳答案   
附件请测试,注意,运行时间比较长,我是2003版,只有256列
  1. Private Sub CommandButton1_Click()
  2. Application.ScreenUpdating = False
  3. Dim sh As Worksheet, a1&, a2&, a3&, i&, j&, k&, arr, r&, r1&
  4. For Each sh In Worksheets
  5.   If sh.Name <> "Sheet1" Then
  6.     arr = sh.UsedRange
  7.     r = sh.[a65536].End(3).Row
  8.     a1 = sh.Cells(r, 1): a2 = sh.Cells(r - 1, 1): a3 = sh.Cells(r - 2, 1)
  9.     For j = 2 To UBound(arr, 2)
  10.       For i = UBound(arr) To 3 Step -1
  11.         If arr(i, j) = a1 Then If arr(i - 1, j) = a2 Then If arr(i - 2, j) = a3 And r - i <> 0 Then sh.Range(sh.Cells(1, j), sh.Cells(r - i, j)).Insert Shift:=xlDown: Exit For
  12.       Next i
  13.     Next j
  14.     arr = sh.Range("a1:iv" & sh.UsedRange.SpecialCells(xlCellTypeLastCell).Row)
  15.     For i = 1 To r - 3
  16.       If arr(i, 1) <> "" Then
  17.         For j = 2 To UBound(arr, 2)
  18.           If arr(i, j) = arr(i, 1) Then sh.Cells(i, j).Interior.Color = vbRed
  19.         Next j
  20.       End If
  21.     Next i
  22.   End If
  23. Next sh
  24. Application.ScreenUpdating = True
  25. End Sub
复制代码

遍历工作表对齐并着色.zip

103.49 KB, 下载次数: 5

评分

参与人数 1 +1 收起 理由
E见如故 + 1 很给力!

查看全部评分

回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-3-29 15:06 , Processed in 0.422761 second(s), 17 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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