怎样按有颜色和无颜色分别提取内容到2个表中

woniu3721

同一工作簿，表一有颜色和无颜色两种数据，现要将有颜色的单元格内容提取到表2，无颜色的提取到表3，提取到表2内容过来后，也可以取消掉颜色。请问该怎么写代码，谢谢！

按颜色提取内容到不同表.zip (10.33 KB, 下载次数: 10)

2024-3-20 23:15 上传

点击文件名下载附件

taller

excel玉米

Sub 提取并区分()
Dim arr() ,b(),i％,j%,m1%,m2%
With sheet1
     i=.cellls(65536,2).end(xlup).row
     Redim arr(1 to i,1 to 2)
     Redim brr(1 to i,1 to 2)
     For j=2  to i
      If .cells(j,2).Interior.ColorIndex<>0 then
              m1=m1+1
              arr(m1,1)=.cells(j,1)
              arr(m1,2)=.cells(j,2)
          Else
               m2=m2+1
              brr(m2,1)=.cells(j,1)
              brr(m2,2)=.cells(j,2)
            End if
       Next  j
End with
Sheet2.cells(1,1)="序号”
Sheet2.cells(1,12)="名称”
Sheet2.cells(2,1).resize(m1,2)=arr
Sheet3.cells(1,1)="序号”
Sheet3.cells(1,12)="名称”
Sheet3.cells(2,1).resize(m2,2)=brr
End if

swl4561255

1. Sub test()
   
2. Dim a, myr, myr1, myr2 As Range
   
3. ar = Range("A1").CurrentRegion.Rows.Count
   
4. Set myr1 = Range("B1")
   
5. Set myr2 = Range("B1")
   
6. For Each a In Range("B2:B" & ar)
   
7.   If a.Interior.ColorIndex > 0 Then
   
8.     Set myr1 = Union(myr1, a)
   
9.   Else
   
10.     Set myr2 = Union(myr2, a)
    
11.   End If
    
12. Next
    
13. myr1.Copy Sheets("sheet2").[A1]
    
14. myr2.Copy Sheets("sheet3").[A1]
    
15. End Sub

复制代码

ykcbf1100

参与一下，原来是条件格式。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.21
   
2.     Dim brr, crr
   
3.     With Sheets("Sheet1")
   
4.         r = .Cells(Rows.Count, 2).End(3).Row
   
5.         arr = .[b1].Resize(r, 1)
   
6.         ReDim brr(1 To r, 1 To 1), crr(1 To r, 1 To 1)
   
7.         On Error Resume Next
   
8.         For i = 2 To UBound(arr)
   
9.             If .Cells(i, 2).DisplayFormat.Interior.ColorIndex > 0 Then
   
10.                 m = m + 1
    
11.                 brr(m, 1) = arr(i, 1)
    
12.             Else
    
13.                 n = n + 1
    
14.                 crr(n, 1) = arr(i, 1)
    
15.             End If
    
16.         Next
    
17.     End With
    
18.     Sheets("Sheet2").UsedRange.Offset(1).Clear
    
19.     Sheets("Sheet2").[a2].Resize(n, 1) = crr
    
20.     Sheets("Sheet3").UsedRange.Offset(1).Clear
    
21.     Sheets("Sheet3").[a2].Resize(m, 1) = brr
    
22.     MsgBox "OK！"
    
23. End Sub
    
24. 
    

复制代码

woniu3721

ykcbf1100 发表于 2024-3-21 09:19
参与一下。。。

可以，只不过你这个是把提到表2和表3的内容互换了一下

woniu3721

swl4561255 发表于 2024-3-21 08:05

简洁高效

woniu3721

经测试，四五楼的方式各有千秋，4楼采用拷贝方式保留原有单元格格式，五楼采用赋值的方式可以消除原来的格式