求帮忙修改一下这段代码，为什么rng1.EntireRow.Copy。只能选中其中一条红色背景的...

sulli112

求帮忙修改一下这段代码，为什么rng1.EntireRow.Copy。只能选中其中一条红色背景的行，而且不能自动粘贴到汇总表
但是如果修改为rng1.EntireRow.delect.却能跨表删除
我想要的效果是，除汇总表外，选中背景颜色为红色的所有行，粘贴在汇总表里面


Sub abc()
Dim rng As Range, rng1 As Range, ws As Worksheet
For Each ws In Worksheets
If ws.Name <> "汇总表" Then

Set rng = ws.Range("a1:g100") '有红色单元格的区域
For Each rng1 In rng
If rng1.Interior.Color = vbRed Then
rng1.EntireRow.Copy

Sheets("汇总表").Cells(k + 1, 1) = rng1.EntireRow.Copy
End If
Next
End If
Next
End Sub

sulli112

Sub TEST()
Dim ARR(1 To 9999, 1 To 10)
For I = 2 To Sheets.Count
    With Sheets(I)
        R = .Cells(Rows.Count, 1).End(xlUp).Row
        For J = 1 To R
            If .Cells(J, 1).Interior.ColorIndex = 6 Then
                N = N + 1
                For K = 1 To 10
                    ARR(N, K) = .Cells(J, K)
                Next
            End If
        Next
    End With
Next
[A3].Resize(9999, 10) = ARR
End Sub
这段代码如果行背景颜色为黄色就可以使用，但是将If .Cells(J, 1).Interior.ColorIndex = 6改为Cells(J, 1).Interior.ColorIndex = 255就运行不了，请问要怎么修改

lele6809

稍改了一下：
Dim rng As Range, rng1 As Range, ws As Worksheet
k = 1
For Each ws In Worksheets
If ws.Name <> "汇总表" Then
Set rng = ws.Range("a1:a100") '有红色单元格的区域
For Each rng1 In rng
If rng1.Interior.Color = vbRed Then
rng1.EntireRow.Copy
Sheets("汇总表").Cells(k, 1).PasteSpecial Paste:=xlPasteValues
k = k + 1
End If
Next
End If
Next

liulang0808

ColorIndex  跟color范围不一样的
到56的

sulli112

Sub TEST()
Dim ARR(1 To 9999, 1 To 19)
For I = 2 To Sheets.Count
    With Sheets(I)
        R = .Cells(Rows.Count, 2).End(xlUp).Row
        For J = 1 To R
            If .Cells(J, 2).Interior.Color = 255 Then
                N = N + 1
                For K = 1 To 19
                    ARR(N, K) = .Cells(J, K)
                Next
            End If
        Next
    End With
Next
[A3].Resize(9999, 19) = ARR
End Sub
这个也行，我修改了一下

sulli112

liulang0808 发表于 2020-5-21 18:42
ColorIndex  跟color范围不一样的
到56的

谢谢，怪不得我试了不行，哈哈

sulli112

1. Sub abc()
   
2. Dim rng As Range, rng1 As Range, ws As Worksheet
   
3. k = 2
   
4. Sheets("汇总表").Range("A2:x10000").ClearContents
   
5. For Each ws In Worksheets
   
6. If ws.Name <> "汇总表" Then
   
7. 
   
8. Set rng = ws.Range("b15:b10000") '有红色单元格的区域
   
9. For Each rng1 In rng
   
10. If rng1.Interior.Color = vbYellow Then
    
11. rng1.EntireRow.Copy
    
12. Sheets("汇总表").Cells(k, 1).PasteSpecial Paste:=xlPasteValues
    
13. k = k + 1
    
14. End If
    
15. Next
    
16. End If
    
17. Next
    
18. End Sub
    

复制代码