excel填色单元格提取数据

108937101

123.zip (16.77 KB, 下载次数: 1)

2024-8-3 18:48 上传

点击文件名下载附件

C：R列单元格中填色单元格，提取数字。
格式如下：
甲1；1.3.5.7.9.11.13.15
甲2；2.4.6.8.10.12.14
.....
这样提取数据

ykcbf1100

既然是求助，你好歹上个附件啊。

108937101

ykcbf1100 发表于 2024-8-3 18:44
既然是求助，你好歹上个附件啊。

123.zip (16.77 KB, 下载次数: 2)

2024-8-3 18:49 上传

点击文件名下载附件

附件，谢谢

提取的数据放在新的工作薄中

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&, strJoin$
   
    Application.ScreenUpdating = False
   
    With [A1].CurrentRegion
        ar = .Value
        ReDim br(1 To UBound(ar), 0)
        For i = 1 To UBound(ar)
            strJoin = ""
            For j = 3 To UBound(ar, 2)
                If .Cells(i, j).Interior.ColorIndex <> -4142 Then
                    strJoin = strJoin & "." & ar(i, j)
                End If
            Next j
            br(i, 0) = ar(i, 1) & ar(i, 2) & ";" & Mid(strJoin, 2)
        Next i
    End With
   
    [U1].Resize(UBound(br)) = br
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

。。。。。。。。。。。

ykcbf1100

108937101 发表于 2024-8-3 18:49
附件，谢谢

提取的数据放在新的工作薄中

另存文件在当前目录下

ykcbf1100

按颜色提取数据

1. Sub ykcbf()  '//2024.8.3
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     p = ThisWorkbook.Path & ""
   
5.     r = Cells(Rows.Count, 1).End(3).Row
   
6.     arr = [a1].Resize(r, 18)
   
7.     ReDim brr(1 To r, 1 To 1)
   
8.     For i = 1 To UBound(arr)
   
9.         m = m + 1
   
10.         st = arr(i, 1) & arr(i, 2) & "；"
    
11.         For j = 3 To UBound(arr, 2)
    
12.             Set Rng = Cells(i, j)
    
13.             If Rng.Cells.Interior.ColorIndex = 47 Then
    
14.                 st = st & Rng.Value & "."
    
15.             End If
    
16.         Next
    
17.         brr(m, 1) = Left(st, Len(st) - 1)
    
18.     Next
    
19.     Application.SheetsInNewWorkbook = 1
    
20.     Set wb = Workbooks.Add
    
21.     wb.Sheets(1).[a1].Resize(UBound(brr), 1) = brr
    
22.     wb.SaveAs p & "数据另存"
    
23.     wb.Close
    
24.     Application.ScreenUpdating = True
    
25.     MsgBox "OK！"
    
26. End Sub
    

复制代码

108937101

gwjkkkkk 发表于 2024-8-3 20:08
。。。。。。。。。。。

谢谢

108937101

ykcbf1100 发表于 2024-8-3 20:28
另存文件在当前目录下

谢谢，