Board logo

標題: 如何找出連續的數字 [打印本頁]
作者: f00l01    時間: 2021-3-29 13:26     標題: 如何找出連續的數字

大家好，終於熬到中學生可以發問，很感謝能有這個機會能找到會Excel的前輩幫忙

(表格詳如附件)
表格內的隨機數字已按大小由左至右排列，請問是否有函數或公式能列出每一列中連續的數字？
(例如：1,,3,4,5,9,12,13,...，能顯示號碼連續者為3,4,5還有12,13)
完整的數量大概會有幾百~2千列不等，一列列幫忙算我可能沒辦法@@

有先搜尋過往文章，但好像和我的問題不太一樣  (小弟所學甚淺，可能看過答案自己都不知道，還請前輩們見諒)

再請論壇上的大神們幫忙。再次感謝論壇維護團隊和大家能給我這個發問的機會。謝謝！
作者: quickfixer    時間: 2021-3-29 14:48

本帖最後由 quickfixer 於 2021-3-29 14:50 編輯

回復 1# f00l01



    [attach]33155[/attach]

笨方法
N欄要留空白
Sub test()
    Columns("O:AA").ClearContents
    For r = 1 To 10 '到第10列
    cc = 1
    ccc = 0
    For c = 2 To 14 '最後一欄+1
        If Cells(r, c) - Cells(r, c - 1) <> 1 Then
            ccc = ccc + 1
            For i = cc To c - 1
            Cells(r, ccc + 14) = Cells(r, ccc + 14) & "," & Cells(r, i) '資料從最後一欄+2開始放
            Next
            cc = c
        End If
    Next
    Next
End Sub
作者: quickfixer    時間: 2021-3-29 15:46

回復 1# f00l01


[attach]33156[/attach]
修正一下,只列出連續數字
    Sub test2()
    Columns("O:AA").ClearContents
    For r = 1 To 10
    cc = 1
    ccc = 0
    For c = 2 To 14
        If Cells(r, c) - Cells(r, c - 1) <> 1 Then
            s = ""
            For i = cc To c - 1
            s = s & "," & Cells(r, i)
            Next
            
            If UBound(Split(s, ",")) <> 1 Then
                ccc = ccc + 1
                Cells(r, ccc + 14) = s
            End If
            cc = c
        End If
    Next
    Next
End Sub
作者: ML089    時間: 2021-3-30 14:21

回復 1# f00l01


因為A1:M5裡的數字有些是文字格式，使用N(OFFSET())公式時無法抓出數字，修正為純數字如下
公式A7 =--A1
複製至 A7:M11

選擇 O7:AA7
輸入陣列公式  = IF(MMULT({1,1},IFERROR(1/((A7:M7+{-1;1}) = N(OFFSET($A7,,COLUMN(A:M)+{-2;0}))),0)),A7:M7,"")
以CTRL+SHIFT+ENTER 輸入公式

選擇 O7:AA7，下拉複製公式
作者: ML089    時間: 2021-3-30 14:32

[attach]33158[/attach]

測試檔案
作者: jcchiang    時間: 2021-3-31 08:03

回復 1# f00l01

試試看
Sub ex()
Dim Arr As Variant, C As Variant, X%, Y%
[A10].CurrentRegion.ClearContents   '資料放置位置,清除資料(請自行調整)
Arr = [a1].CurrentRegion
Set C = Nothing
For X = 1 To UBound(Arr)
   For Y = 1 To UBound(Arr, 2) - 1
      If Cells(X, Y) - Cells(X, Y + 1) = -1 Then  '判斷是否為連續數值
         If C Is Nothing Then
            Set C = Cells(X, Y).Resize(, 2)
         Else
            Set C = Union(C, Cells(X, Y).Resize(, 2))
         End If
      End If
   Next
   C.Copy [A10].Offset(X).Resize(, C.Count)    '資料放置位置(請自行調整)
   Set C = Nothing
Next
End Sub
作者: samwang    時間: 2021-3-31 08:20

回復 1# f00l01

不知道是否為樓主需求，請測試看看，謝謝。
Sub tt()
Dim Arr, Brr(), T%, T1%, L%, M%, i&, j&, C%
Columns("O:AA").ClearContents
Arr = [a1].CurrentRegion
ReDim Brr(1 To UBound(Arr), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr)
    M = 0: L = 0: C = 0
    For j = 1 To UBound(Arr, 2)
        If j + 1 > UBound(Arr, 2) Then
            If T1 = T + 1 Then Brr(i, M) = Mid(Brr(i, M) & "," & Arr(i, j), 2)
            Exit For
        End If
        T = Arr(i, j): T1 = Arr(i, j + 1)
        If T1 = T + 1 Then
            If C = 0 Then M = M + 1
            Brr(i, M) = Brr(i, M) & "," & Arr(i, j): C = 1
        Else
            If T > L + 1 Then GoTo 99
            Brr(i, M) = Mid(Brr(i, M) & "," & Arr(i, j), 2): C = 0
        End If
        L = T
99:  Next
Next
Range("o1").Resize(UBound(Brr), UBound(Brr, 2)) = Brr
End Sub
作者: f00l01    時間: 2021-3-31 10:07

想不到問身邊的人都解不出來的問題

來麻辣家族討論區開問一下子就跳出大神幫忙~~

感謝  quickfixer (超快！) 還有 ML089 的兩次貼文詳解

也要謝謝 jcchiang、 samwang 提供解方

我現在都來試試看，有問題再前來拜問

再一次謝謝幫忙的各層樓主和麻辣家族的團隊！
作者: hcm19522    時間: 2021-3-31 12:46

https://blog.xuite.net/hcm19522/twblog/589693174
作者: samwang    時間: 2021-3-31 13:57

回復 1# f00l01

連續數字單獨個別放在單一儲存格，請測試看看，謝謝。
Sub tt1()
Dim Arr, Brr(), T%, T1%, L%, M%, i&, j&
Columns("O:AA").ClearContents
Arr = [a1].CurrentRegion
ReDim Brr(1 To UBound(Arr), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr)
    M = 0: L = 0
    For j = 1 To UBound(Arr, 2)
        If j + 1 > UBound(Arr, 2) Then
            If T1 = T + 1 Then M = M + 1: Brr(i, M) = Arr(i, j)
            Exit For
        End If
        T = Arr(i, j): T1 = Arr(i, j + 1)
        If T1 = T + 1 Then
            M = M + 1: Brr(i, M) = Arr(i, j)
        Else
            If T > L + 1 Then GoTo 99
            M = M + 1: Brr(i, M) = Arr(i, j)
        End If
        L = T
99:  Next
Next
Range("o1").Resize(UBound(Brr), UBound(Brr, 2)) = Brr
End Sub
作者: 准提部林    時間: 2021-3-31 18:22

P1//陣列公式(三鍵輸入)
=iferror(SMALL(IF(MMULT({1,1},COUNTIF($A1:$M1,$A1:$M1+{1;-1}))>0,--$A1:$M1),COLUMN(A1)),"")
作者: 准提部林    時間: 2021-3-31 19:15

Sub TEST()
Dim Arr, V&, U1&, U2&, i&, j%, T$
Arr = Range([A1], [m65536].End(xlUp))
For i = 1 To UBound(Arr)
    V = -9 ^ 9
    For j = 1 To UBound(Arr, 2)
        U1 = Arr(i, j):  U2 = U1
        If j < UBound(Arr, 2) Then U2 = Arr(i, j + 1)
        If U1 - V = 1 Or U2 - U1 = 1 Then T = T & "," & U1: V = U1
    Next j
    Arr(i, 1) = Mid(T, 2): T = ""
Next i
[O1].Resize(UBound(Arr)) = Arr
End Sub
作者: samwang    時間: 2021-4-1 09:52

回復 1# f00l01

全部連續值顯示在同一格儲存格如照片，請測試看看，謝謝。
Sub tt2()
Dim Arr, TT, T%, T1%, L%, i&, j&
[o1].CurrentRegion = ""
Arr = [a1].CurrentRegion
For i = 1 To UBound(Arr)
    L = 0
    For j = 1 To UBound(Arr, 2)
        If j < UBound(Arr, 2) Then T1 = Arr(i, j + 1)
        T = Arr(i, j)
        If T1 - T = 1 Or T - L = 1 Then
            TT = TT & "," & Arr(i, j): L = T
        End If
    Next
    Arr(i, 1) = Mid(TT, 2): TT = ""
Next
Range("o1").Resize(UBound(Arr)) = Arr
End Sub
作者: 准提部林    時間: 2021-4-1 13:39

回復 13# samwang


A1 改成 1 試試~~
作者: samwang    時間: 2021-4-1 17:28

回復 14# 准提部林


感謝准大指導，真的有問題，有空時再來想看看如何解，感謝。
作者: samwang    時間: 2021-4-1 21:22

感謝准大細心，又學到小技巧，更新如下，謝謝

Sub tt3()
Dim Arr, TT, T%, T1%, L&, i&, j&
[o1].CurrentRegion = ""
Arr = [a1].CurrentRegion
For i = 1 To UBound(Arr)
    L = 9 ^ 9
    For j = 1 To UBound(Arr, 2)
        If j < UBound(Arr, 2) Then T1 = Arr(i, j + 1)
        T = Arr(i, j)
        If T1 - T = 1 Or T - L = 1 Then
            TT = TT & "," & T: L = T
        End If
    Next
    Arr(i, 1) = Mid(TT, 2): TT = ""
Next
Range("o1").Resize(UBound(Arr)) = Arr
End Sub
作者: f00l01    時間: 2021-4-22 18:01

謝謝大家，我再找時間好好了解每個解方。

再次感謝！！
作者: Andy2483    時間: 2022-10-31 10:50

本帖最後由 Andy2483 於 2022-10-31 10:53 編輯

回復 12# 准提部林


    '謝謝前輩
'這帖學到
'1.資料型態:長整數的最小值 是-2147483648
'2.知道什麼是數字溢位
'3.不能只看問題的正面!負面的也要考慮!畢竟主角是數字
'4.防誤判是很重要的事!
'5.很多知識與學問是練習才能體會的!
'6.天助自助人助
請前輩再指導!謝謝
Option Explicit
Sub TEST()
Dim Arr, V&, U1&, U2&, i&, j%, T$
'↑宣告變數
Arr = Range([A1], [m65536].End(xlUp))
'↑令Arr是陣列!倒入[A1]到M欄最後一個有內容儲存格,擴展到方正最小區域儲存格值
For i = 1 To UBound(Arr)
'↑設外順迴圈!從1到Arr陣列縱向最後一列數
    V = -9 ^ 9
    '↑令V數字是9的9次方負值=(9 ^ 9)*(-1)= -387420489
    '查詢了VBA 的資料型態: V& 長整數的最小值 是-2147483648 !
    '為什麼不用它當V值??  因為後方程序會讓變數溢位(比 -2147483648 更小)
    '因為V的初始值是0 如果一開始沒有給V一個第一使用值
    '後方的程序會誤判[A1]=1 時連續
    For j = 1 To UBound(Arr, 2)
    '↑設內順迴圈!從1到Arr陣列橫向最後一欄數
        U1 = Arr(i, j)
        '↑令U1是Arr陣列內外迴圈的主角(數字)
        U2 = U1
        '↑U2 = U1是為了 消除U2在前次迴圈中殘餘數字(U2初始值是0)
        If j < UBound(Arr, 2) Then
        '↑如果j這內迴圈數小於 Arr陣列橫向最後一欄數
           U2 = Arr(i, j + 1)
           'U2就變心成為 U1主角右邊格的那個值(數字)
        End If
        If U1 - V = 1 Or U2 - U1 = 1 Then
        '↑如果主角U1 - V =1,是要判斷負數值的連續
        '或 變心U2的-主角U1=1
           T = T & "," & U1
           '↑令T =T字串連接 "," 符號 ,再連接主角U1
           V = U1
           '↑令V數字是主角U1值
        End If
    Next j
    Arr(i, 1) = Mid(T, 2)
    '↑令外迴圈Arr陣列的第一欄取內迴圈 T字串裡的第2個字開始(含自己)的全部字串
    '↑Mid(T, 2)後學今天才知道可以這樣陳述!以前都用Mid(T, 2,99)
    '因為第一個字是 "," 符號
    T = ""
    '↑令清空 T字串
Next i
[O1].Resize(UBound(Arr)) = Arr
'↑Arr陣列 從[O1]開始貼入 Arr陣列縱向最後一列數,只貼入1欄位資料
'同[O1].Resize(UBound(Arr), 1) = Arr,1可以省略
End Sub

執行前:
[attach]35432[/attach]

執行結果:
[attach]35433[/attach]
作者: Andy2483    時間: 2022-10-31 13:13

回復 12# 准提部林


    謝謝前輩
此帖後學用陣列與字典練習心得如下
請前輩再指導!謝謝
1.能不必用字典就不要刻意使用! 資料倒進倒出都需要時間
2.用變數直接傳遞訊息較快

前輩的程式碼執行10000列的時間:
[attach]35434[/attach]

後學的程式碼執行10000列的時間:
[attach]35435[/attach]

Option Explicit
Sub TEST_2()
Dim Arr, i&, j&, T, V, Y, U1, U2, S
S = Timer
Set Y = CreateObject("Scripting.Dictionary")
Arr = Range([A1], [m65536].End(xlUp))
[O:O].ClearContents
For i = 1 To UBound(Arr)
   V = -9 ^ 9
   For j = 1 To UBound(Arr, 2)
      If j < UBound(Arr, 2) Then
         U1 = Arr(i, j): U2 = Arr(i, j + 1)
         If U1 * U2 >= 0 Then
            Y(U1) = IIf(Y(U1) <> 1, Abs((U2) - (U1)), Y(U1))
            Y(U2) = IIf(Y(U2) <> 1, Abs((U2) - (U1)), Y(U1))
         End If
      End If
   Next
   For Each T In Y.KEYS
      If Y(T) <> 1 Then
         Y.Remove (T)
      End If
   Next
   Arr(i, 1) = Join(Application.Transpose(Application.Transpose(Y.KEYS)), ",")
   Y.RemoveAll
Next
[O1].Resize(UBound(Arr)) = Arr
MsgBox Timer - S & "秒"
End Sub
作者: Andy2483    時間: 2022-10-31 13:59

字典key轉置的方式改成迴圈直接寫入陣列少!稍好!
[attach]35436[/attach]

Option Explicit
Sub TEST_3()
Dim Arr, i&, j&, T, V, Y, U1, U2, S
S = Timer
Set Y = CreateObject("Scripting.Dictionary")
Arr = Range([A1], [m65536].End(xlUp))
[O:O].ClearContents
For i = 1 To UBound(Arr)
   V = -9 ^ 9
   For j = 1 To UBound(Arr, 2)
      If j < UBound(Arr, 2) Then
         U1 = Arr(i, j): U2 = Arr(i, j + 1)
         If U1 * U2 >= 0 Then
            Y(U1) = IIf(Y(U1) <> 1, Abs((U2) - (U1)), Y(U1))
            Y(U2) = IIf(Y(U2) <> 1, Abs((U2) - (U1)), Y(U1))
         End If
      End If
   Next
   Arr(i, 1) = ""
   For Each T In Y.KEYS
      If Y(T) <> 1 Then
         Y.Remove (T)
         Else
            Arr(i, 1) = Arr(i, 1) & "," & T
      End If
   Next
   Arr(i, 1) = Mid(Arr(i, 1), 2)
   Y.RemoveAll
Next
[O1].Resize(UBound(Arr)) = Arr
MsgBox Timer - S & "秒"
End Sub
作者: Andy2483    時間: 2022-10-31 16:30

深入研究耗時:
單就判斷與建立字典庫!就耗時0.6秒
Option Explicit
Sub TEST_4()
Dim Arr, i&, j&, T, V, Y, U1, U2, S, P$
S = Timer
Set Y = CreateObject("Scripting.Dictionary")
Arr = Range([A1], [m65536].End(xlUp))
[O:O].ClearContents
For i = 1 To UBound(Arr)
   V = -9 ^ 9
   For j = 1 To UBound(Arr, 2)
      If j < UBound(Arr, 2) Then
         U1 = Arr(i, j): U2 = Arr(i, j + 1)
         If U1 * U2 >= 0 Then
            Y(U1) = IIf(Y(U1) <> 1, Abs((U2) - (U1)), Y(U1))
            Y(U2) = IIf(Y(U2) <> 1, Abs((U2) - (U1)), Y(U1))
         End If
      End If
   Next
   Y.RemoveAll
Next
MsgBox Timer - S & "秒"
End Sub

去除IIF判斷! 0.3秒!
Option Explicit
Sub TEST_4()
Dim Arr, i&, j&, T, V, Y, U1, U2, S, P$
S = Timer
Set Y = CreateObject("Scripting.Dictionary")
Arr = Range([A1], [m65536].End(xlUp))
[O:O].ClearContents
For i = 1 To UBound(Arr)
   V = -9 ^ 9
   For j = 1 To UBound(Arr, 2)
      If j < UBound(Arr, 2) Then
         U1 = Arr(i, j): U2 = Arr(i, j + 1)
         If U1 * U2 >= 0 Then
            Y(U1) = ""
            Y(U2) = ""
         End If
      End If
   Next
   Y.RemoveAll
Next
MsgBox Timer - S & "秒"
End Sub

光是反覆字典建立/清空!就要 0.25秒!
Option Explicit
Sub TEST_4()
Dim Arr, i&, j&, T, V, Y, U1, U2, S, P$
S = Timer
Set Y = CreateObject("Scripting.Dictionary")
Arr = Range([A1], [m65536].End(xlUp))
[O:O].ClearContents
For i = 1 To UBound(Arr)
   V = -9 ^ 9
   For j = 1 To UBound(Arr, 2)
      If j < UBound(Arr, 2) Then
         U1 = Arr(i, j)
         Y(U1) = ""
      End If
   Next
   Y.RemoveAll
Next
MsgBox Timer - S & "秒"
End Sub



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)