昨日知ったApplication.InputBoxの延長でもう一つ作った。
概要
- 飛び飛びのセルを複数選択コピーする機能は、コピー側は可能だがペースト側が不可能なため後者を可能にする。
- 使い方：最初のInputBoxで複数セルを順次コピーして、次のInputBoxで順次選択したセルにペーストする。
- 複数選択、範囲選択可能。
残課題
@jinojiさんのコメントで課題解決しました！！！
ありがとうございます！！！
複数選択数がコピー／ペーストで異なる場合、小さい方に合わせて出力され、余剰範囲に#N/Aが出力される。範囲サイズがコピー／ペーストで異なる場合、小さい方に合わせて出力され、余剰範囲に#N/Aが出力される。
コード
Option Explicit
'適宜変更してください
Const 待ち時間 = 300 'ミリ秒
Const 分母 = 86400000 '待ち時間のミリ秒変換分母
Dim CB()
Sub 飛び飛びセル順次コピペ()
If 順次コピー = True Then
Call 順次ペースト
End If
End Sub
Private Function 順次コピー() As Boolean
'InputBox用の説明文
Dim Cmt(1)
Cmt(0) = "セルを選択してください。"
Cmt(1) = "（Ctrlで複数選択可能。ドラッグで範囲選択可能）"
Dim Prompt: Prompt = Join(Cmt, vbCrLf)
Const Title = "順次セル選択：コピー"
'メイン
On Error GoTo エラー処理
Dim rng As Range
Set rng = Application.InputBox(Prompt, Title, Type:=8)
rng.Select
ReDim CB(rng.Cells.Count - 1)
Dim c As Range, i As Long
For Each c In rng.Cells
CB(i) = c.Value
i = i + 1
Next
順次コピー = True
Exit Function
エラー処理:
Select Case Err.Number
Case 424
Err.Clear
Case Else
MsgBox Err.Number & Err.Description
End Select
順次コピー = False
End Function
Private Sub 順次ペースト()
'InputBox用の説明文
Dim Cmt(1)
Cmt(0) = "セルを選択してください。"
Cmt(1) = "（Ctrlで複数選択可能。ドラッグで範囲選択可能）"
Dim Prompt: Prompt = Join(Cmt, vbCrLf)
Const Title = "順次セル選択：ペースト"
'メイン
On Error GoTo エラー処理
Dim rng As Range
Set rng = Application.InputBox(Prompt, Title, Type:=8)
rng.Select
Dim ub, c As Range, i As Long
ub = UBound(CB)
For Each c In rng.Cells
c.Value = CB(i)
i = i + 1
If i > ub Then Exit For
Next
Exit Sub
エラー処理:
Select Case Err.Number
Case 424
Err.Clear
Case Else
MsgBox Err.Number & Err.Description
End Select
End Sub
コード（旧）
↓改善前↓
Option Explicit
'ここを変えければ変える
Const 待ち時間 = 300 'ミリ秒
Const 分母 = 86400000 '待ち時間のミリ秒変換分母
Dim CB()
Sub 飛び飛びセル順次コピペ()
If 順次コピー = True Then
Call 順次ペースト
End If
End Sub
Private Function 順次コピー() As Boolean
'InputBox用の説明文
Dim Cmt(1)
Cmt(0) = "セルを選択してください。"
Cmt(1) = "（Ctrlで複数選択可能。ドラッグで範囲選択可能）"
Dim Prompt: Prompt = Join(Cmt, vbCrLf)
Const Title = "順次セル選択：コピー"
'メイン
On Error GoTo エラー処理
Dim rng As Range
Set rng = Application.InputBox(Prompt, Title, Type:=8)
rng.Select
Dim Target: Target = Split(rng.Address, ",")
Dim i As Long
For i = 0 To UBound(Target)
ReDim Preserve CB(i)
CB(i) = Range(Target(i)).Value
Next
順次コピー = True
Exit Function
エラー処理:
Select Case Err.Number
Case 424
Err.Clear
Case Else
MsgBox Err.Number & Err.Description
End Select
順次コピー = False
End Function
Private Sub 順次ペースト()
'InputBox用の説明文
Dim Cmt(1)
Cmt(0) = "セルを選択してください。"
Cmt(1) = "（Ctrlで複数選択可能。ドラッグで範囲選択可能）"
Dim Prompt: Prompt = Join(Cmt, vbCrLf)
Const Title = "順次セル選択：ペースト"
'メイン
On Error GoTo エラー処理
Dim rng As Range
Set rng = Application.InputBox(Prompt, Title, Type:=8)
rng.Select
Dim Target: Target = Split(rng.Address, ",")
Dim i As Long
For i = 0 To UBound(Target)
Range(Target(i)).Value = CB(i)
Next
Exit Sub
エラー処理:
Select Case Err.Number
Case 9
MsgBox "ペースト数がコピー数が一致しませんでした。少ない方で出力しました。"
Case 424
Err.Clear
Case Else
MsgBox Err.Number & Err.Description
End Select
End Sub