- 帖子
- 1018
- 主題
- 15
- 精華
- 0
- 積分
- 1058
- 點名
- 0
- 作業系統
- win7 32bit
- 軟體版本
- Office 2016 64-bit
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 桃園
- 註冊時間
- 2012-5-9
- 最後登錄
- 2022-9-28
|
4#
發表於 2013-12-5 13:46
| 只看該作者
回復 1# c_c_lai
寫得挺亂的，包涵哈~
d1字典 : Address , 面積
d2字典 : 面積 , 個數
依需求再自己改改吧- Sub test()
- Dim d1, d2, bCombine As Boolean, lCol As Long
- Dim stripe As Range, stripeOffset As Range, rngTarget As Range
-
- Set d1 = CreateObject("scripting.dictionary")
- With Sheets(1).[A1].CurrentRegion
- .Replace What:="0", Replacement:=""
- For lCol = 1 To .Columns.Count
- If Application.CountA(.Columns(lCol).Cells) < .Columns(lCol).Cells.Count Then
- For Each stripe In .Columns(lCol).SpecialCells(xlCellTypeBlanks).Areas
- If stripe.Column = 1 Then
- Set stripeOffset = stripe
- Else
- Set stripeOffset = .Parent.Range(stripe.Address).Offset(0, -1)
- End If
- bCombine = False
- For Each prev In d1.keys
- If Not Application.Intersect(.Parent.Range(prev), stripeOffset) Is Nothing Then
- If d1.exists(stripe.Address) Then d1.Remove (stripe.Address)
- Set stripe = Union(.Parent.Range(prev), stripe)
- d1.Remove prev
- d1(stripe.Address) = stripe.Count
- Set stripeOffset = Union(stripeOffset, .Parent.Range(prev))
- bCombine = True
- End If
- Next prev
- If Not bCombine Then d1(stripe.Address) = stripe.Count
- Next stripe
- End If
- Next lCol
- .Replace What:="", Replacement:="0"
- End With
-
- Set d2 = CreateObject("scripting.dictionary")
- For Each x In d1.items
- If d2.exists(x) Then
- d2(x) = d2(x) + 1
- Else
- d2(x) = 1
- End If
- Next
- For Each x In d2.keys
- Debug.Print "面積 " & x & " : " & d2(x) & "個"
- Next
- End Sub
|
|
，結果如下