これは、目的の領域の各行でコードを実行できるようにする例です(選択範囲の上下から、選択範囲から選択してください)。
Sub doROWSb() 'WORKS for do selected rows SEE FIX ROWS ABOVE (small ver)
Dim E7 As String 'note: workcell E7 shows: BG381
E7 = RANGE("E7") 'see eg below
Dim r As Long 'NOTE: this example has a paste formula(s) down a column(s). WILL REDUCE 10 HOUR DAYS OF PASTING COLUMNS, DOWN TO 3 MINUTES?
Dim c As Long
Dim rCell As RANGE
'Dim LastRow As Long
r = ActiveCell.row
c = ActiveCell.Column 'might not matter if your code affects whole line anyways, still leave as is
Dim FirstRow As Long 'not in use, Delete if only want last row, note: this code already allows for selection as start
Dim LastRow As Long
If 1 Then 'if you are unable to delete rows not needed, just change 2 lines from: If 1, to if 0 (to go from selection last row, to all rows down from selection)
With Selection
'FirstRow = .Rows(1).row 'not used here, Delete if only want last row
LastRow = .Rows(.Rows.Count).row 'find last row in selection
End With
application.CutCopyMode = False 'if not doing any paste op below
Else
LastRow = Cells(Rows.Count, 1).End(xlUp).row 'find last row used in sheet
End If
application.EnableEvents = True 'EVENTS need this?
application.ScreenUpdating = False 'offset-cells(row, col)
'RANGE(E7).Select 'TOP ROW SELECT
RANGE("A1") = vbNullString 'simple macros on-off switch, vb not here: If RANGE("A1").Value > 0 Then
For Each rCell In RANGE(Cells(r, c), Cells(LastRow, c)) 'new
rCell.Select 'make 3 macros for each paste macro below
'your code here:
If 1 Then 'to if 0, if want to paste formulas/formats/all down a column
Selection.EntireRow.Calculate 'calcs all selected rows, even if just selecting 1 cell in each row (might only be doing 1 row aat here, as part of loop)
Else
'dorows() DO ROWS()
'eg's for paste cells down a column, can make 3 separate macros for each: sub alte() altf & altp
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'make sub alte () add thisworkbook: application.OnKey "%{e}", "alte"
'Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'make sub altf () add thisworkbook: application.OnKey "%{f}", "altf"
'Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'amke sub altp () add thisworkbook: application.OnKey "%{p}", "altp"
End If
Next rCell
'application.CutCopyMode = False 'finished - stop copy mode
'RANGE("A2").Select
goBEEPS (2), (0.25) 'beeps secs
application.EnableEvents = True 'EVENTS
'note: workcell E7 has: SUBSTITUTE(SUBSTITUTE(CELL("address",$BG$369),"$",""),"","")
'other col eg (shows: BG:BG): =SUBSTITUTE(SUBSTITUTE(CELL("address",$BG2),"$",""),ROW(),"")&":"& SUBSTITUTE(SUBSTITUTE(CELL("address",$BG2),"$",""),ROW(),"")
End Sub
'OTHER:
Sub goBEEPSx(b As Long, t As Double) 'beeps secs as: goBEEPS (2), (0.25) OR: goBEEPS(2, 0.25)
Dim dt 'as double 'worked wo as double
Dim x
For b = b To 1 Step -1
Beep
x = Timer
Do
DoEvents
dt = Timer - x
If dt < 0 Then dt = dt + 86400 '86400 no. seconds in a day, in case hit midnight & timer went down to 0
Loop Until dt >= t
Next
End Sub