按要求提取标色数据

杨小妹

00000000000附件 按要求提取标色数据.rar (366.59 KB, 下载次数: 30)

2024-3-20 15:03 上传

点击文件名下载附件

谢谢老师！

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.3.20
   
2.     Application.ScreenUpdating = False
   
3.     With Sheets("Sheet2")
   
4.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
   
5.         c = .UsedRange.Columns.Count
   
6.         arr = .[a1].Resize(r, c)
   
7.         ReDim brr(1 To UBound(arr), 1 To 7)
   
8.         For j = 1 To UBound(arr, 2) Step 6
   
9.             For i = 1 To UBound(arr)
   
10.                 If .Cells(i, j).Interior.ColorIndex = 8 And .Cells(i, j + 1).Interior.ColorIndex = 8 Then
    
11.                     m = m + 1
    
12.                     brr(m, 1) = arr(i, j)
    
13.                     brr(m, 2) = arr(i, j + 1)
    
14.                     brr(m, 4) = arr(i, j + 3)
    
15.                     brr(m, 5) = arr(i, j + 4)
    
16.                     brr(m, 6) = i
    
17.                     brr(m, 7) = j
    
18.                 End If
    
19.             Next
    
20.         Next
    
21.     End With
    
22.     With Sheets("Sheet1")
    
23.         If m > 0 Then
    
24.             .[w:ac] = ""
    
25.             .[w1].Resize(m, 7) = brr
    
26.         End If
    
27.     End With
    
28.     Application.ScreenUpdating = True
    
29.     MsgBox "OK！"
    
30. End Sub
    

复制代码

半百

确定不需要列出列号？

1. Sub test()
   
2. Set Rng = Sheets(2).UsedRange
   
3. For i = 1 To Rng.Columns.Count Step 6
   
4.     For j = 1 To Rng.Rows.Count
   
5.         If Rng(j, i).Resize(1, 2).Interior.ColorIndex = 8 Then
   
6.             n = n + 1
   
7.             Cells(n, "w").Resize(1, 5) = Rng(j, i).Resize(1, 5).Value
   
8.             Cells(n, "ab") = j
   
9.         End If
   
10.     Next
    
11. Next
    
12. End Sub
    

复制代码

杨小妹

半百 发表于 2024-3-20 16:21
确定不需要列出列号？

老师你好，谢谢帮助。麻烦把列号也标出来。谢谢了。

杨小妹

ykcbf1100 发表于 2024-3-20 15:24
参与一下。。。

老师你好，谢谢帮助。试了一下，五千列可以正常运行，助效果很好。又试了一下一万列，提示内存溢出。麻烦看看能否修正一下，谢谢了。

ykcbf1100

杨小妹 发表于 2024-3-20 17:59
老师你好，谢谢帮助。试了一下，五千列可以正常运行，助效果很好。又试了一下一万列，提示内存溢出。麻烦 ...

代码应该没问题，我刚才试了一下6万多行都能出来，就是卡顿了一下而已。标色主要是要对单元格操作，速度会慢一点的。这个和电脑的配置也有关系。

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, br, cr, i&, j&, k, r&, isFlag As Boolean
   
    With Sheets(2).UsedRange
        ar = .Value
        ReDim br(1 To UBound(ar) * UBound(ar, 2), 1 To 7)
        For j = 1 To UBound(ar, 2) Step 6
            For i = 1 To UBound(ar)
                isFlag = True
                For k = 0 To 1
                    If .Cells(i, j + k).Interior.Color = 16777215 Then
                        isFlag = False: Exit For
                    End If
                Next k
                If isFlag Then
                    r = r + 1
                    For k = 0 To 4
                        br(r, k + 1) = ar(i, j + k)
                    Next k
                    br(r, 6) = i
                    br(r, 7) = j
                End If
            Next i
        Next j
    End With
   
    Columns("W:AC").Clear
    [W1].Resize(r, UBound(br, 2)) = br
    Beep
End Sub

gwjkkkkk

请参考附件。。。

杨小妹

gwjkkkkk 发表于 2024-3-20 18:59
请参考附件。。。

老师你好，谢谢帮助。试了一下，3600列左右，可正常运行。3700列左右，就提示内存溢出了。