跳格累加(頁 1) - Excel程式區 - 麻辣家族討論版版

johnny1680 發表於 2021-10-18 21:45

跳格累加

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

samwang 發表於 2021-10-19 11:26

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=117313&ptid=23424]1#[/url] [i]johnny1680[/i] [/b]

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

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=117313&ptid=23424]1#[/url] [i]johnny1680[/i] [/b]

簡化#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

[url]https://blog.xuite.net/hcm19522/twblog/590079887[/url]

johnny1680 發表於 2021-11-7 19:36

[i=s] 本帖最後由 johnny1680 於 2021-11-7 19:39 編輯 [/i]

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=117324&ptid=23424]3#[/url] [i]samwang[/i] [/b]
[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=117325&ptid=23424]4#[/url] [i]hcm19522[/i] [/b]

[color=Blue]感謝二位大大的幫忙![/color]

Andy2483 發表於 2023-12-11 09:00

[i=s] 本帖最後由 Andy2483 於 2023-12-11 09:05 編輯 [/i]

謝謝論壇,謝謝各位前輩
後學藉此帖練習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

[i=s] 本帖最後由 singo1232001 於 2023-12-11 11:00 編輯 [/i]

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網址:[url]https://hcm19522.blogspot.com/[/url]

頁: [1]

麻辣家族討論版版's Archiver

跳格累加