飛び飛びセル順次コピペ

昨日知ったApplication.InputBoxの延長でもう一つ作った。

## 概要
- 飛び飛びのセルを複数選択コピーする機能は、コピー側は可能だがペースト側が不可能なため後者を可能にする。
- 使い方：最初のInputBoxで複数セルを順次コピーして、次のInputBoxで順次選択したセルにペーストする。
- 複数選択、範囲選択可能。

## 残課題
@jinojiさんのコメントで課題解決しました！！！
ありがとうございます！！！

- ~~複数選択数がコピー／ペーストで異なる場合、小さい方に合わせて出力され、余剰範囲に#N/Aが出力される。~~
- ~~範囲サイズがコピー／ペーストで異なる場合、小さい方に合わせて出力され、余剰範囲に#N/Aが出力される。~~

## コード


``` vb
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

```

## コード（旧）
<details><summary>↓改善前↓</summary><div>

``` vb
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


```
</div></details>