提取数据

wkxxxr

填充底色单元格内容提取到工作表，详见附件，请大佬帮忙。谢谢！

ykcbf1100

附件供参考。。。

ykcbf1100

1. Sub ykcbf()  '//2025.12.1
   
2.     With Sheets("原始表")
   
3.         r = .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
   
4.         c = .Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
   
5.         arr = .[a1].Resize(r, c).Value
   
6.         ReDim brr(1 To r, 1 To c)
   
7.         m = 1
   
8.         For j = 1 To UBound(arr, 2)
   
9.             brr(1, j) = arr(2, j)
   
10.         Next
    
11.         For i = 3 To UBound(arr)
    
12.             For j = 1 To UBound(arr, 2)
    
13.                 If arr(i, j) = Empty Then arr(i, j) = arr(i - 1, j)
    
14.             Next
    
15.             Set Rng = .Cells(i, 3)
    
16.             If Rng.Interior.ColorIndex <> -4142 Then
    
17.                 m = m + 1
    
18.                 For j = 1 To UBound(arr, 2)
    
19.                     brr(m, j) = arr(i, j)
    
20.                 Next
    
21.                 xm = Rng.Interior.ColorIndex
    
22.             End If
    
23.         Next
    
24.     End With
    
25.     With Sheets("目标表")
    
26.         .Cells.Interior.ColorIndex = 0
    
27.         .Cells.ClearContents
    
28.         .[a2].Resize(m, c) = brr
    
29.         .[a2].Resize(m, c).Borders.LineStyle = 1
    
30.         .[a3].Resize(m - 1, c).Interior.ColorIndex = xm
    
31.     End With
    
32. End Sub
    

复制代码

gwjkkkkk

gwjkkkkk

Option Explicit
Sub test1()
    Dim ar, i&, j&, r&
   
    With Worksheets(1)
        r = .Cells(.Rows.Count, "A").End(xlUp).Row
        With .Range("A2:J" & r)
            ar = .Value: r = 1
            For i = 2 To UBound(ar)
                If .Rows(i).Interior.Color = 15773696 Then
                    r = r + 1
                    For j = 1 To UBound(ar, 2)
                        ar(r, j) = ar(i, j)
                    Next j
                    ar(r, 1) = .Cells(r, 1).MergeArea.Value
                    ar(r, 2) = .Cells(r, 2).MergeArea.Value
                End If
            Next i
        End With
    End With
   
    With Worksheets(2)
        .Cells.Clear
        With .Range("A2").Resize(r, UBound(ar, 2))
            .Value = ar
            .HorizontalAlignment = xlCenter
        End With
        .Activate
    End With
    Beep
End Sub

laoye5403

..............................................

wkxxxr

laoye5403 发表于 2025-12-1 20:02
..............................................

合并单元格跳到下一格

guihuawc

ykcbf1100 发表于 2025-12-1 15:37
附件供参考。。。

佩服　代码简洁　思路清晰