查找连续的数字（继续寻找方法）

大灰狼1976

手机回复：
s=“若干单元格地址不超255字符长度”
msgbox union(range(s),range(s)).address(0,0)

aman1516

ggmmlol 发表于 2021-3-2 13:05
既然T字符串是由公式得来的，又要用VBA处理，还不如全程都用VBA处理。

T 不是公式得来的，单元格不是固定而是动态变化的，是代码根据更每次新后的数据及不同条件判断得来，
表格数据全部可用代码一次生成，但由于要方便表格的后继操作及维护需求，才将不同公式写入到特定单元格内，
故需对 T 进行处理，以便能套用公式。此处的字符串仅为示例。

lss001

aman1516 发表于 2021-3-2 13:45
T 不是公式得来的，单元格不是固定而是动态变化的，是代码根据更每次新后的数据及不同条件判断得来，
表 ...

Sub no1()
    Dim r As Range, s, t, d, h, i, j, k, m
    t = "D18,D15,D1:D3,D22,D23,D24,D25,D12,D11,D10,D7,D4,D27:D32"
    s = Split(t, ",") '处理字符/字符数>255
    For i = 1 To UBound(s) \ 12 + 1
        k = ""
        For j = 1 To 12
            k = k & s(n) & ",": n = n + 1
            If n > UBound(s) Then Exit For
        Next
        k = Left(k, Len(k) - 1) '合并区域
        If i = 1 Then Set t = Range(k) Else Set t = Union(t, Range(k))
    Next
    Set d = CreateObject("scripting.dictionary")
    For Each h In t.Areas '建立字典/利用Areas属性
        m = m + 1: d.Add h.Row, CStr(m)
    Next
    For i = 1 To t.Areas.Count '查找字典/利用Areas属性
        j = Application.Small(d.keys, i) '
        If r Is Nothing Then '排序区域
            Set r = Range(t.Areas.Item(d.Item(j)).Address)
        Else
            Set r = Union(r, Range(t.Areas.Item(d.Item(j)).Address))
        End If
    Next
    MsgBox r.Address(0, 0)
End Sub

ggmmlol

以下代码不限T的长度。仅限D列。

1. Sub Test()
   
2.     Const T = "D23,D22,D35,D12,D72,D20,D39,D5,D75,D3,D69,D45,D2,D46,D51,D1,D21,D78,D7,D13,D31,D97,D52,D17,D65,D82,D71,D56,D58,D33,D60,D6,D43,D95,D40,D53,D87,D63,D4,D92,D76,D8,D81,D70,D99,D74,D24,D38,D55,D27,D96,D79,D89,D77,D36,D11,D37,D59,D42,D73,D18,D93,D62,D44,D68,D50,D57,D9,D90,D94,D85,D30,D34,D15,D54,D98,D67,D29,D66,D49,D80,D41,D88,D10,D28,D64,D84,D83,D16,D86,D47,D91,D25,D32,D26,D14,D48,D61,D19"
   
3.     MsgBox MergeAdr(T)
   
4. End Sub
   
5. Function MergeAdr$(ByVal adr$)
   
6.     Const rmax = 1048576
   
7.     Ts = Split(Replace(adr, "D", ""), ",")
   
8.     r = UBound(Ts)
   
9.     Dim rs(0 To rmax) As Boolean
   
10.     For i = 0 To r
    
11.         p = Val(Ts(i))
    
12.         rs(p) = True
    
13.     Next
    
14.     For i = 1 To rmax
    
15.         If rs(i - 1) Then
    
16.             If rs(i) Then
    
17.                 If i = rmax Then ss = ss & ":D" & i : Exit For
    
18.                 n = n + 1
    
19.             Else
    
20.                 If i - 1 > st Then ss = ss & ":D" & i - 1
    
21.             End If
    
22.         Else
    
23.             If rs(i) Then
    
24.                 st = i
    
25.                 ss = ss & ",D" & st
    
26.                 n = n + 1
    
27.             End If
    
28.         End If
    
29.         If n = r + 1 Then
    
30.             If i > st Then ss = ss & ":D" & i
    
31.             Exit For
    
32.         End If
    
33.     Next
    
34.     MergeAdr = Mid(ss, 2)
    
35. End Function

复制代码

准提部林

以圖片例子, 位址如何編排???
使用定位法, 會因選取方式而產生歧異, 也不可能達到目的!!!

                  (1)                                           (2)                        
   

aman1516

准提部林 发表于 2021-3-2 15:55
以圖片例子, 位址如何編排???
使用定位法, 會因選取方式而產生歧異, 也不可能達到目的!!!

只有两个规则，不然就没法整了：
小于6行以下的，以行为连续，
大于等于6 行以上的，以列为连续，但6 行以上当跨列为整齐的方形时（4 个及以上单元格区域的，不论横竖），作为一个连片区域
即相当于第（2）种方案

aman1516

测试了一下，似乎 Union 以“最大面积”优先方式合并地址：

1. Sub t99()
   
2. Dim T As String, Rng As Range, ran As Range
   
3. T = "D18,E18,D19,E19,C15:D17,B1:E1,B2,B3,B4,C4,D26,D27,D24,D25,D12,D11,D10,D7,C10:C12,D4,A28:D32,B10,B11,B12,A2,A3,A4,A5"
   
4. sr = Split(T, ",")
   
5. For i = 0 To UBound(sr)
   
6.     If Rng Is Nothing Then Set Rng = Range(sr(i)) Else Set Rng = Union(Rng, Range(sr(i)))
   
7. Next
   
8. Cells(1, 1) = T
   
9. Cells(2, 1) = Rng.Address(0, 0)
   
10. Rng.Select
    
11. Cells(3, 1) = Selection.Address(0, 0)
    
12. End Sub

复制代码

而  NoteText 的方法结果是不一样的：

1. Sub t77()
   
2. Dim T$, Rng As Range, A As Range
   
3.   T = "D18,E18,D19,E19,C15:D17,B1:E1,B2,B3,B4,C4,D26,D27,D24,D25,D12,D11,D10,D7,C10:C12,D4,A28:D32,B10,B11,B12,A2,A3,A4,A5"
   
4. Set Rng = Range(T)
   
5. For Each A In Rng
   
6.      A.NoteText "test"
   
7. Next
   
8. With Rng.EntireColumn
   
9.       T = .SpecialCells(xlCellTypeComments).Address(0, 0)
   
10.       .ClearComments
    
11. End With
    
12. Cells(4, 1) = T
    
13. End Sub

复制代码

准提部林

aman1516 发表于 2021-3-2 16:50
只有两个规则，不然没法整了：
当小于6 行的，以行为准
大于等于6 行以上的，以列为准，但大于6 行且跨 ...

加這兩規則, 反而更難了~~
應該是先清楚哪些單元格需要用哪個公式,
事先分類分組, 取出不同組合~放各自的公式才對

aman1516

准提部林 发表于 2021-3-2 17:40
加這兩規則, 反而更難了~~
應該是先清楚哪些單元格需要用哪個公式,
事先分類分組, 取出不同組合~放各自 ...

是的，那就退而求之，不管横竖，只判断里面哪些单元格是方形的连片区域，其他都不管，这样也能暂时分开处理应用。
一点头绪都没有，挀脑壳......也没啥的借鉴

aman1516

与 Rng.EntireColumn 和 Rng.EntireRow  相关：

1. Sub t66()
   
2. Dim T$, Rng As Range, A As Range
   
3. T = "D18,E18,D19,E19,C15:D17,B1:E1,B2,B3,B4,C4,D26,D27,D24,D25,D12,D11,D10,D7,C10:C12,D4,A28:D32,B10,B11,B12,A2,A3,A4,A5"
   
4. Set Rng = Range(T)
   
5. For Each A In Rng
   
6.      A.NoteText "test"
   
7. Next
   
8. With Rng.EntireRow
   
9.       T = .SpecialCells(xlCellTypeComments).Address(0, 0)
   
10.       .ClearComments
    
11. End With
    
12. Cells(6, 1) = T
    
13. End Sub

复制代码