[已解决]VBA求助

fxe2001x

大家好，我想从表格中把不同填充颜色的单元格数据导出成一列数据，怎么编写？请详细解释一下，谢谢！

最佳答案

月排行榜 / 总排行榜

limonet

2022-6-6 15:34

Sub SplitColor()
    Dim Rng As Range
    With CreateObject("scripting.dictionary")
        For Each Rng In Range("A1").CurrentRegion
            .Item(Rng.Interior.Color) = Rng & "@" & .Item(Rng.Interior.Color)
        Next Rng
        For i% = 0 To .Count - 1
            Sheet2.Cells(1, i + 1).Resize(UBound(Split(.Item(.keys()(i)), "@"), 1) + 1, 1) = Application.Transpose(Split(.Item(.keys()(i)), "@"))
        Next i
    End With
End Sub

跳转到最佳答案楼层

hasyh2008

Sub tt()
  On Error Resume Next
  Application.ScreenUpdating = False '//关闭屏幕刷新
  Application.DisplayAlerts = False '//关闭系统提示
  Application.EnableEvents = False  '//禁止触发其他事件
  Application.StatusBar = False   '关闭系统状态条
  Application.Interactive = False   '禁用鼠标、键盘，防干扰
  Dim D, D2
  Dim Rng As Range
  Dim Ys As Long, Cels As Long
  Dim Rc%, Co%, K%
  Dim Tim As Single
  Tim = Timer
  Dim Arr()
  Set D = CreateObject("scripting.dictionary")
  Set D2 = CreateObject("scripting.dictionary")
  Cels = Sheet1.Range("A1").CurrentRegion.Count     '统计单元格总个数
  For Each Rng In Sheet1.Range("A1").CurrentRegion
    Ys = Rng.Interior.Color
    If D.Exists(Ys) Then
      D2(Ys) = D2(Ys) + 1
      If D2(Ys) > K Then K = D2(Ys)                 '记录数组一维方向的最高值
      Arr(D2(Ys), D(Ys)) = Rng.Value
    Else
      Co = Co + 1
      D(Ys) = Co: D2(Ys) = 1                        'D(Ys):新出现颜色的列数,D2(Ys):行数取1
      ReDim Preserve Arr(1 To Cels, 1 To Co)        '数组一维方向取最大值，二维为准确值
      Arr(1, Co) = Rng.Value
      Sheet2.Cells(1, Co).Interior.Color = Ys       '设置第一行的颜色
    End If
  Next Rng
  Sheet2.Range("A1").Resize(K, Co) = Arr
  MsgBox Format(Timer - Tim, "0.00")
  Set Rng = Nothing
  Application.StatusBar = True   '恢复系统状态条
  Application.EnableEvents = True  '//恢复触发其他事件
  Application.ScreenUpdating = True '//恢复屏幕刷新
  Application.DisplayAlerts = True '//恢复系统提示
  Application.Interactive = True    '启用鼠标键盘
End Sub

limonet

Sub SplitColor()
    Dim Rng As Range
    With CreateObject("scripting.dictionary")
        For Each Rng In Range("A1").CurrentRegion
            .Item(Rng.Interior.Color) = Rng & "@" & .Item(Rng.Interior.Color)
        Next Rng
        For i% = 0 To .Count - 1
            Sheet2.Cells(1, i + 1).Resize(UBound(Split(.Item(.keys()(i)), "@"), 1) + 1, 1) = Application.Transpose(Split(.Item(.keys()(i)), "@"))
        Next i
    End With
End Sub

hasyh2008

limonet 发表于 2022-6-6 15:34
Sub SplitColor()
    Dim Rng As Range
    With CreateObject("scripting.dictionary")

得好好学习学习！！！高手都是不走寻常路！！！以前看过这样的做法，一直没用过，今天得消化下！！！！

limonet

hasyh2008 发表于 2022-6-6 15:56
得好好学习学习！！！高手都是不走寻常路！！！

不论黑猫白猫，能抓到老鼠就是好猫。

limonet

这个可能更好，排序自然，表头对应颜色
Sub SplitColor()
    Dim Rng As Range
    With CreateObject("scripting.dictionary")
        For Each Rng In Range("A1").CurrentRegion
            .Item(Rng.Interior.Color) = .Item(Rng.Interior.Color) & "@" & Rng
        Next Rng
        For i% = 0 To .Count - 1
            Sheet2.Cells(1, i + 1).Resize(UBound(Split(.Item(.keys()(i)), "@")) + 1) = Application.Transpose(Split(.keys()(i) & .Item(.keys()(i)), "@"))
            Sheet2.Cells(1, i + 1).Interior.Color = .keys()(i)
        Next i
    End With
End Su