请教大家1个VBA操作的问题，字典和数组不熟悉，有思路，但是不会写代码

hezudao_long · 发表于 2023-12-22 14:20

思路逻辑在文件和图片上，请得闲的坛友指点

cyh3230 · 发表于 2023-12-22 15:36

直接结果2吧, 结果1没有什么意思,不想弄了

Sub colorcombine()
Dim ar()
Dim br()
Dim rng As Range
Set d = CreateObject("scripting.dictionary")
r = Range("a65536").End(xlUp).Row
k = 1
ReDim ar(1 To k)
For i = 2 To r
If Cells(i, 1).Interior.Color <> Cells(i + 1, 1).Interior.Color Then
ReDim Preserve ar(1 To k)
ar(k) = i
k = k + 1
End If
Next i
For k = 1 To UBound(ar) - 1
For Each rng In Range(Cells(ar(k) + 1, 1), Cells(ar(k + 1), 1))
d(rng.Value) = ""
Next
ReDim Preserve br(1 To k)
br(k) = Join(d.keys, ";")
d.RemoveAll
Next k
For i = 1 To UBound(br)
Range("d" & i + 2) = "区域" & i
Range("e" & i + 2) = br(i)
Range("e" & i + 2).Interior.Color = Range("a" & ar(i + 1)).Interior.Color
Next i
End Sub

复制代码

3190496160 · 发表于 2023-12-22 16:45

Sub 区域去重复()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long, rs As Long
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("原始数据区域")
r = .Cells(Rows.Count, 1).End(xlUp).Row
ReDim br(1 To r)
n = 1
br(n) = 3
For i = 3 To r
      If .Cells(i, 1).Interior.ColorIndex <> .Cells(i + 1, 1).Interior.ColorIndex Then
         n = n + 2
         br(n - 1) = i
         br(n) = i + 1
      End If
Next i
ReDim brr(1 To n, 1 To 3)
For s = 1 To n - 1 Step 2
      m = m + 1
      brr(m, 1) = "区域" & m
      d.RemoveAll
      ks = br(s)
      js = br(s + 1)
      brr(m, 3) = .Cells(ks, 1).Interior.ColorIndex
      ar = .Range(.Cells(ks, 1), .Cells(js, 1))
      For i = 1 To UBound(ar)
         If ar(i, 1) <> "" Then
            If Not d.exists(ar(i, 1)) Then
                  If brr(m, 2) = "" Then
                     brr(m, 2) = ar(i, 1)
                  Else
                     brr(m, 2) = brr(m, 2) & "," & ar(i, 1)
                  End If
                  d(ar(i, 1)) = ""
            End If
         End If
      Next i
Next s
End With
With Sheets("期望的结果数据表2")
.UsedRange.Clear
k = 1
For i = 1 To m
      k = k + 1
      .Cells(k, 1).Resize(1, 2) = Application.Index(brr, i, 0)
      .Cells(k, 1).Resize(1, 2).Interior.ColorIndex = brr(i, 3)
Next i
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub