急需帮助！！！！请大家帮帮忙，不胜感激。

zhangru2199 · 发表于 2018-7-23 13:59

怎样把Sheet1中 N 、O、AC、AD列的红色字体或红色背景的单元格所在的那一行依次复制到Sheet2中,要求不能有重复的行

lsdongjh · 发表于 2018-7-23 14:28

Sub Test()
Dim shSource As Worksheet, shResult As Worksheet
Dim arrSource As Variant
Dim lngRow As Long
Dim rgFind As Range, rg As Range
Dim blIsRED As Boolean, lngRowID As Long
Set shSource = Sheets("Sheet1")
Set shResult = Sheets("Sheet2")
arrSource = shSource.UsedRange
shResult.UsedRange.ClearContents
shResult.Cells.Font.Size = 9
shResult.Range("B:B").NumberFormatLocal = "@"
'列标题
shResult.Range("A1").Resize(1, UBound(arrSource, 2)) = Application.WorksheetFunction.Index(arrSource, 1, 0)
lngRowID = 2
For lngRow = 2 To UBound(arrSource)
Set rgFind = Union(shSource.Range("N" & lngRow & ":O" & lngRow), shSource.Range("AC" & lngRow & ":AD" & lngRow))
blIsRED = False
For Each rg In rgFind
If rg.Font.ColorIndex = 3 Or rg.Interior.ColorIndex = 3 Then
blIsRED = True
Exit For
End If
Next
If blIsRED = True Then
shResult.Range("A" & lngRowID).Resize(1, UBound(arrSource, 2)) = Application.WorksheetFunction.Index(arrSource, lngRow, 0)
lngRowID = lngRowID + 1
End If
Next
MsgBox "成功提取数据【" & lngRowID - 2 & "】条"
End Sub

复制代码

zhangru2199 · 发表于 2018-7-23 15:31

非常感谢！！还有一个问题，我在另一个表格中运行此程序出现数据粘贴不全，有一行变红现象，请大神帮忙看看

zhangru2199 · 发表于 2018-7-23 15:41

大神还在不，麻烦了

lsdongjh · 发表于 2018-7-23 15:44

你原来的表格，部分单元格带有格式，重新设置一下，或在代码中加入：shResult.Cells.ClearFormats
傲游截图20180723154417.png

zhangru2199 · 发表于 2018-7-23 15:52

太厉害了，现在可以了，非常感谢

zhangru2199 · 发表于 2018-7-23 15:59

请问您知道我原来标注的红色字体，和红色背景能否一并复制过去

		自动登录	找回密码
密码			免费注册

[求助] 急需帮助！！！！请大家帮帮忙，不胜感激。