標題: [發問] 跳格累加 [打印本頁]

---

作者: johnny1680    時間: 2021-10-18 21:45     標題: 跳格累加

[attach]34235[/attach]
當A1填入某數字，然後每間隔5列會自動累加10
例如：A1=100，然後A6=110，A11=120，A16=130，A21=140，A26=150，----其餘類推----下拉到A101。
請問：函數公式要怎麼編輯？
謝謝！

---

作者: samwang    時間: 2021-10-19 11:26

回復 1# johnny1680


Sub test()
Dim R As Range, xD, n%
Set xD = CreateObject("Scripting.Dictionary")
For Each R In Range("a2:a101")
    n = n + 1
    If n = 5 Then
        If xD.exists(Cells(1, 1).Value) Then
        R.Value = xD(Cells(1, 1).Value) + 10
        xD(Cells(1, 1).Value) = R: n = 0
        Else
        R.Value = Cells(1, 1) + 10
        xD(Cells(1, 1).Value) = R: n = 0
        End If
    End If
Next
End Sub

---

作者: samwang    時間: 2021-10-19 13:10

回復 1# johnny1680

簡化#2，謝謝
Sub test2()
Dim Arr, xD
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range("a1:a101")
For i = 6 To UBound(Arr) Step 5
    If xD.Exists(Arr(1, 1)) Then
        Arr(i, 1) = xD(Arr(1, 1)) + 10
        xD(Arr(1, 1)) = Arr(i, 1)
    Else
        Arr(i, 1) = Arr(1, 1) + 10
        xD(Arr(1, 1)) = Arr(i, 1)
    End If
Next
Range("a1").Resize(UBound(Arr), 1) = Arr
End Sub

---

作者: hcm19522    時間: 2021-10-19 14:46

https://blog.xuite.net/hcm19522/twblog/590079887

---

作者: johnny1680    時間: 2021-11-7 19:36

本帖最後由 johnny1680 於 2021-11-7 19:39 編輯

回復 3# samwang
回復 4# hcm19522

感謝二位大大的幫忙!

---

作者: Andy2483    時間: 2023-12-11 09:00

本帖最後由 Andy2483 於 2023-12-11 09:05 編輯

謝謝論壇,謝謝各位前輩
後學藉此帖練習Do Until Loop,學習方案如下,請各位前輩指教
執行前:
[attach]37116[/attach]

執行結果:
[attach]37117[/attach]

一般模組:
Option Explicit
Sub TEST()
Dim Y%, R%, xR As Range
Set xR = [A1]
Do Until R >= 101
   Y = Y + 1
   R = Y * 5 + 1
   xR(R) = Val(xR) + 10 * Y
Loop
End Sub

工作表模組:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) = "A1" Then Call TEST
End Sub

---

作者: singo1232001    時間: 2023-12-11 10:52

本帖最後由 singo1232001 於 2023-12-11 11:00 編輯

Private Sub Worksheet_Change(ByVal Target As Range)
'防錯很好用
If Target.Height > 10000000 Then Exit Sub  '防全選溢位報錯
If Target.Width > 1000000 Then Exit Sub   '防全選溢位報錯
If Target.Count > 1 Then Exit Sub      '防多選回溯報錯
If Target.Value = "" Then Exit Sub    '防空值計算報錯
If Target.Column > 1 Then Exit Sub
If Target.Row > 1 Then Exit Sub
If IsNumeric(Target.Value) = False Then Exit Sub  '防非數字計算報錯

'二元一次聯立方程式 (可刪除註解)
'y = ax + b
'0= 1a + b     '1列=0
'10= 6a + b    '6列=10
'a = -b
'代入 10=-5b
'b=-2
'代回 0=a-2
'a=2
'求出 y=2x-2

ReDim ar(1 To 101, 0)
For i = 1 To 101 Step 5
ar(i, 0) = i * 2 - 2 + Target.Value   '代入公式y=2x-2 +原始值
Next
Target.Resize(101, 1) = ar
End Sub

---

作者: hcm19522    時間: 2023-12-11 11:20

(輸入編號12120) google網址:https://hcm19522.blogspot.com/

---

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