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

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 求助VBA 删除所有子表A列单元格没有高亮的行
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 860|回复: 8

求助VBA 删除所有子表A列单元格没有高亮的行

[复制链接]
t2019er
发表于 2022-6-1 17:44 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
1.删除所有子表没有高亮的行；
2.取消所有子表行的高亮；

多谢，各位老师！

合并、项目已拆分.rar

239.12 KB, 下载次数: 4
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
发表于 2022-6-1 22:33 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上

請測試看看，謝謝

Sub test()
Dim Sht, sh, Sn$
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sht = Sheets.Count
For sh = 2 To Sht
    Sheets(sh).Select
    Sn = Split(Sheets(sh).Name, "_")(1)
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = Sn
    With Sheets(sh)
        With .Range(.[L1], .[a65536].End(3))
           .AutoFilter Field:=1, Criteria1:=RGB(255, 255 _
                , 0), Operator:=xlFilterCellColor
           .SpecialCells(xlCellTypeVisible).Copy Sheets(Sn).[A1]
           Sheets(Sn).Cells.Interior.Pattern = xlNone
        End With
    End With
Next
For sh = Sht To 2 Step -1: Sheets(sh).Delete: Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

回复

使用道具 举报

发表于 2022-6-1 22:40 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上


上次提供的程式，你使用有問題，我猜應該Clr = xR.DisplayFormat.Interior.ColorIndex這句，這要2010版本以上才能用
所以提供不一樣的解法#2程式，執行結果如圖片，使用篩選顏色-->copy-->新增Sht-->刪除舊的sht，請再測試看看，謝謝
1.png
回复

使用道具 举报

t2019er
 楼主| 发表于 2022-6-1 23:21 | 显示全部楼层
sam-wang 发表于 2022-6-1 22:40
上次提供的程式，你使用有問題，我猜應該Clr = xR.DisplayFormat.Interior.ColorIndex這句，這要2010版 ...

十二分的感谢！

还是有点小问题，使用这个方法处理的子表格式发生了变化，图片和文本重叠了，无法使用，有没有办法可以解决？

另外我这边使用的是2013版。上次提供的程式， 子表找到的项目都一样，我是小白，算法我看不懂，也不知道怎么改。



回复

使用道具 举报

t2019er
 楼主| 发表于 2022-6-1 23:29 | 显示全部楼层
sam-wang 发表于 2022-6-1 22:40
上次提供的程式，你使用有問題，我猜應該Clr = xR.DisplayFormat.Interior.ColorIndex這句，這要2010版 ...

单个表格的删除非高亮项目，取消所有高亮，我尝试用穷举法做好了，各个子表一次执行完成，能力有限做不出来？

能否帮我改成For sh = 2 To Sheets.Count 都能用的程式

以下是单个sheet的程式


Sub 删除非检测项目取消高亮()
Dim sh As Integer

Application.ScreenUpdating = False

'删除非检测项目
If Cells(705, 1).Interior.ColorIndex <> 6 Then
       Range("A693:J710").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(687, 1).Interior.ColorIndex <> 6 Then
       Range("A675:J692").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(669, 1).Interior.ColorIndex <> 6 Then
       Range("A657:J674").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(651, 1).Interior.ColorIndex <> 6 Then
       Range("A639:J656").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(633, 1).Interior.ColorIndex <> 6 Then
       Range("A621:J638").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(615, 1).Interior.ColorIndex <> 6 Then
       Range("A603:J620").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(597, 1).Interior.ColorIndex <> 6 Then
       Range("A585:J602").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(579, 1).Interior.ColorIndex <> 6 Then
       Range("A567:J584").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(561, 1).Interior.ColorIndex <> 6 Then
       Range("A549:J566").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(543, 1).Interior.ColorIndex <> 6 Then
       Range("A531:J548").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(525, 1).Interior.ColorIndex <> 6 Then
       Range("A513:J530").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(507, 1).Interior.ColorIndex <> 6 Then
       Range("A495:J512").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(489, 1).Interior.ColorIndex <> 6 Then
       Range("A477:J494").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(471, 1).Interior.ColorIndex <> 6 Then
       Range("A459:J476").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(453, 1).Interior.ColorIndex <> 6 Then
       Range("A441:J458").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(435, 1).Interior.ColorIndex <> 6 Then
       Range("A423:J440").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(417, 1).Interior.ColorIndex <> 6 Then
       Range("A405:J422").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(399, 1).Interior.ColorIndex <> 6 Then
       Range("A387:J404").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(381, 1).Interior.ColorIndex <> 6 Then
       Range("A369:J386").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(363, 1).Interior.ColorIndex <> 6 Then
       Range("A351:J368").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(345, 1).Interior.ColorIndex <> 6 Then
       Range("A333:J350").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(327, 1).Interior.ColorIndex <> 6 Then
       Range("A315:J332").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(309, 1).Interior.ColorIndex <> 6 Then
       Range("A297:J314").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(291, 1).Interior.ColorIndex <> 6 Then
       Range("A279:J296").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(273, 1).Interior.ColorIndex <> 6 Then
       Range("A261:J278").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(255, 1).Interior.ColorIndex <> 6 Then
       Range("A243:J260").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(237, 1).Interior.ColorIndex <> 6 Then
       Range("A225:J242").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(219, 1).Interior.ColorIndex <> 6 Then
       Range("A207:J224").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(201, 1).Interior.ColorIndex <> 6 Then
       Range("A189:J206").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(183, 1).Interior.ColorIndex <> 6 Then
       Range("A171:J188").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(165, 1).Interior.ColorIndex <> 6 Then
       Range("A153:J170").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(147, 1).Interior.ColorIndex <> 6 Then
       Range("A135:J152").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(129, 1).Interior.ColorIndex <> 6 Then
       Range("A117:J134").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(111, 1).Interior.ColorIndex <> 6 Then
       Range("A99:J116").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(93, 1).Interior.ColorIndex <> 6 Then
       Range("A81:J98").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(75, 1).Interior.ColorIndex <> 6 Then
       Range("A63:J80").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(57, 1).Interior.ColorIndex <> 6 Then
       Range("A45:J62").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(39, 1).Interior.ColorIndex <> 6 Then
       Range("A27:J44").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(21, 1).Interior.ColorIndex <> 6 Then
       Range("A9:J26").Select
         Selection.Delete Shift:=xlUp
End If

' 取消高亮
Range("A1:Q200").Interior.ColorIndex = -4142


End Sub


回复

使用道具 举报

发表于 2022-6-2 07:02 | 显示全部楼层
本帖最后由 sam-wang 于 2022-6-2 07:05 编辑
t2019er 发表于 2022-6-1 23:21
十二分的感谢！

还是有点小问题，使用这个方法处理的子表格式发生了变化，图片和文本重叠了，无法使用 ...

不好意思，我太了解您遇到問題請提供圖片描述，不知是否方便提供你的檔案讓我測試，謝謝

另外，可以使用F8和中斷點來除錯，
回复

使用道具 举报

发表于 2022-6-2 07:19 | 显示全部楼层
t2019er 发表于 2022-6-1 23:29
单个表格的删除非高亮项目，取消所有高亮，我尝试用穷举法做好了，各个子表一次执行完成，能力有限做不出 ...


新增如下3列紅字，謝謝

Sub 删除非检测项目取消高亮()
Dim sh As Integer

Application.ScreenUpdating = False

For sh = 2 To Sheets.Count
Sheets(sh).Select
If Cells(705, 1).Interior.ColorIndex <> 6 Then
       Range("A693:J710").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(687, 1).Interior.ColorIndex <> 6 Then
       Range("A675:J692").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(669, 1).Interior.ColorIndex <> 6 Then
       Range("A657:J674").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(651, 1).Interior.ColorIndex <> 6 Then
       Range("A639:J656").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(633, 1).Interior.ColorIndex <> 6 Then
       Range("A621:J638").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(615, 1).Interior.ColorIndex <> 6 Then
       Range("A603:J620").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(597, 1).Interior.ColorIndex <> 6 Then
       Range("A585:J602").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(579, 1).Interior.ColorIndex <> 6 Then
       Range("A567:J584").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(561, 1).Interior.ColorIndex <> 6 Then
       Range("A549:J566").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(543, 1).Interior.ColorIndex <> 6 Then
       Range("A531:J548").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(525, 1).Interior.ColorIndex <> 6 Then
       Range("A513:J530").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(507, 1).Interior.ColorIndex <> 6 Then
       Range("A495:J512").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(489, 1).Interior.ColorIndex <> 6 Then
       Range("A477:J494").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(471, 1).Interior.ColorIndex <> 6 Then
       Range("A459:J476").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(453, 1).Interior.ColorIndex <> 6 Then
       Range("A441:J458").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(435, 1).Interior.ColorIndex <> 6 Then
       Range("A423:J440").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(417, 1).Interior.ColorIndex <> 6 Then
       Range("A405:J422").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(399, 1).Interior.ColorIndex <> 6 Then
       Range("A387:J404").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(381, 1).Interior.ColorIndex <> 6 Then
       Range("A369:J386").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(363, 1).Interior.ColorIndex <> 6 Then
       Range("A351:J368").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(345, 1).Interior.ColorIndex <> 6 Then
       Range("A333:J350").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(327, 1).Interior.ColorIndex <> 6 Then
       Range("A315:J332").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(309, 1).Interior.ColorIndex <> 6 Then
       Range("A297:J314").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(291, 1).Interior.ColorIndex <> 6 Then
       Range("A279:J296").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(273, 1).Interior.ColorIndex <> 6 Then
       Range("A261:J278").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(255, 1).Interior.ColorIndex <> 6 Then
       Range("A243:J260").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(237, 1).Interior.ColorIndex <> 6 Then
       Range("A225:J242").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(219, 1).Interior.ColorIndex <> 6 Then
       Range("A207:J224").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(201, 1).Interior.ColorIndex <> 6 Then
       Range("A189:J206").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(183, 1).Interior.ColorIndex <> 6 Then
       Range("A171:J188").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(165, 1).Interior.ColorIndex <> 6 Then
       Range("A153:J170").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(147, 1).Interior.ColorIndex <> 6 Then
       Range("A135:J152").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(129, 1).Interior.ColorIndex <> 6 Then
       Range("A117:J134").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(111, 1).Interior.ColorIndex <> 6 Then
       Range("A99:J116").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(93, 1).Interior.ColorIndex <> 6 Then
       Range("A81:J98").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(75, 1).Interior.ColorIndex <> 6 Then
       Range("A63:J80").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(57, 1).Interior.ColorIndex <> 6 Then
       Range("A45:J62").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(39, 1).Interior.ColorIndex <> 6 Then
       Range("A27:J44").Select
         Selection.Delete Shift:=xlUp
End If

If Cells(21, 1).Interior.ColorIndex <> 6 Then
       Range("A9:J26").Select
         Selection.Delete Shift:=xlUp
End If

' 取消高亮
Range("A1:Q200").Interior.ColorIndex = -4142
Next

End Sub



回复

使用道具 举报

发表于 2022-6-2 07:24 | 显示全部楼层
t2019er 发表于 2022-6-1 23:29
单个表格的删除非高亮项目，取消所有高亮，我尝试用穷举法做好了，各个子表一次执行完成，能力有限做不出 ...



#5樓的作法是有問題的吧? 執行結果如圖片，請確認一下，謝謝
1.png
回复

使用道具 举报

t2019er
 楼主| 发表于 2022-6-2 08:57 | 显示全部楼层
sam-wang 发表于 2022-6-2 07:02
不好意思，我太了解您遇到問題請提供圖片描述，不知是否方便提供你的檔案讓我測試，謝謝

另外，可以使 ...

使用您提供的程式处理的结果没有报错问题，问题在文档内容格式发生了变化，如图。 QQ截图20220602085424.png

回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-9-21 18:15 , Processed in 0.325733 second(s), 8 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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