Excel2016でリボルビングコピペ

質問

sheet8のセル範囲C3:C10000までの各セルに記号値A～Jのいずれかがランダムに入ってます。

マクロボタンを押します。
C3:C10000の範囲の内から
何個か行番数を選びます。
選ばれた行番数から50行戻った所までの範囲の記号値を横化して、
O4:BL4の範囲から下に向かって6000行程繰り返してコピペしたいです。

繰り返しコピペの際に選んだ行番数に＋1 をして同じ形の行には成らないようにしたいです。

(抜き出して、リボルバーみたいに回転してコピペするけど、コピペされる度に行番数に＋1 されてるので同じではない、みたいな感じです。)
教えて頂けたら幸いです。

回答No.14

kkkkkm · ベストアンサー

> 自分で作った物は保存をし次からの選択肢に加えることもできますか？

Sheet8のA2から下方向に保存していく(最後にブックを保存しなければ消える)

Private Sub CommandButton1_Click()
Dim buf As Variant, SRow As Variant
Dim i As Long, k As Long, j As Long: j = 0
Dim InputStr As String
Dim FRng As Range
Dim cCount As Long, LFlg As Boolean: LFlg = False

InputStr = Me.TextBox1.Value
If InputStr = "" Then Exit Sub

SRow = Split(InputStr, ",")
For i = LBound(SRow) To UBound(SRow)
If SRow(i) < 53 Or SRow(i) > 9950 Then
MsgBox SRow(i) & " は指定可能範囲から外れています。", vbCritical
Exit Sub
End If
Next
For cCount = 0 To Me.ListBox1.ListCount - 1
If Me.ListBox1.List(cCount) = InputStr Then
LFlg = True
Exit For
End If
Next
If LFlg = False Then
With Sheets("Sheet8")
Set FRng = .Range(.Cells(2, "A"), .Cells(Rows.Count, "A").End(xlUp)).Find(What:=InputStr, LookIn:=xlValues, LookAt:=xlWhole)
If FRng Is Nothing Then
With .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
.NumberFormat = "@"
.Value = InputStr
Me.ListBox1.AddItem InputStr
End With
End If
End With
End If
With Sheets("Sheet8")
.Cells(4, "O").Resize(6003, 50).ClearContents
For k = 4 To 6003 Step UBound(SRow) - LBound(SRow) + 1
For i = LBound(SRow) To UBound(SRow)
buf = .Range(.Cells(SRow(i) + j - 50, "C"), .Cells(SRow(i) + j, "C")).Value
.Cells(k + i, "O").Resize(1, 50).Value = WorksheetFunction.Transpose(buf)
Next
j = j + 1
Next
End With
MsgBox "終了", vbInformation
Unload Me '←ダイアログを消さない場合いらない
End Sub

Private Sub CommandButton2_Click()
Unload Me
End Sub

Private Sub ListBox1_Click()
Me.TextBox1.Value = Me.ListBox1.Value
End Sub

Private Sub UserForm_Initialize()
Dim i As Long
With Me.ListBox1
.AddItem "53,1050,2050,5050"
.AddItem "67,890,1210,560,458"
.AddItem "478,59,1506"
For i = 2 To Sheets("Sheet8").Cells(Rows.Count, "A").End(xlUp).Row
.AddItem Sheets("Sheet8").Cells(i, "A").Value
Next
End With
UserForm1.Caption = "行の選択/指定"
End Sub

お礼

こんばんはkkkkkm さん。このソースもNo. 13と同様にすればよろしいのでしょうか？

回答No.18

kkkkkm

"C"を"D"に変更してください。

お礼

できました。
本当にいつも助かります。
kkkkkm さん改めて言わせて頂きます。
ありがとうございました。
また宜しくお願い致します。

回答No.17

kkkkkm

フォームの名前がUserForm1なら
Sub Test()
UserForm1.Show
End Sub

ユーザーフォームを開くで検索ぐらいはしましょう。

お礼

ありがとうございます。あのソースではC列から選出する形でしたが、仮に、D列から選出するとすれば、あのソースのCの部分をCに変えるだけで大丈夫でしょうか？

補足

＞あのソースのCの部分をCに変えるだけで大丈夫でしょうか？

Dでした。

回答No.16

kkkkkm

> エラーがでましたので、返答お願いします。

できたフォームをダブルクリックしてマクロの画面を出して

開いた時に
Private Sub UserForm_Click()

End Sub

ができたら削除し

お礼

すみません。コンパイルできました。
できたそれを実行したいのですがどうすればよろしいだすか？マクロリストを見てもありませんし。

回答No.15

kkkkkm

> このソースもNo. 13と同様にすればよろしいのでしょうか？

No13のコードの部分を変更してください。

お礼

こんにちは、kkkkkm さんいつもありがとうございます。
エラーがでましたので、返答お願いします。
＞InputStr = Me.TextBox1.Value
If InputStr = "" Then Exit Sub
Me キーワードの使用方法が不正です。

となります。宜しくお願いします。

回答No.13

kkkkkm

添付画像(左がデザイン時、右が動作時)のダイヤログを利用したときの動作
下のボックスの一覧を選択すると上のボックスに表示される
自分で指定したい場合は上のボックスに自分で入力する
決定ボタンを押すと上のボックスのデータで実行される

VBAの画面でユーザーフォームを作ります(作り方はサイト検索で見つけてください)

説明の部分はラベル(Label1)
上の細長いボックスはテキストボックス(TextBox1)
下の高さがあるボックスはリストボックス(ListBox1)
一番下のボタンはコマンドボタン
決定の方(CommandButton1)
キャンセルの方(CommandButton2)
上から順番に作ると()内の名前になっていますので変更しない。

できたフォームをダブルクリックしてマクロの画面を出して

開いた時に
Private Sub UserForm_Click()

End Sub

ができたら削除し

そこに以下をコピペ

Private Sub CommandButton1_Click()
Dim buf As Variant, SRow As Variant
Dim i As Long, k As Long, j As Long: j = 0
Dim InputStr As String

InputStr = Me.TextBox1.Value
If InputStr = "" Then Exit Sub
SRow = Split(InputStr, ",")
For i = LBound(SRow) To UBound(SRow)
If SRow(i) < 53 Or SRow(i) > 9950 Then
MsgBox SRow(i) & " は指定可能範囲から外れています。", vbCritical
Exit Sub
End If
Next
With Sheets("Sheet8")
.Cells(4, "O").Resize(6003, 50).ClearContents
For k = 4 To 6003 Step UBound(SRow) - LBound(SRow) + 1
For i = LBound(SRow) To UBound(SRow)
buf = .Range(.Cells(SRow(i) + j - 50, "C"), .Cells(SRow(i) + j, "C")).Value
.Cells(k + i, "O").Resize(1, 50).Value = WorksheetFunction.Transpose(buf)
Next
j = j + 1
Next
End With
MsgBox "終了", vbInformation
Unload Me '←ダイアログを消さない場合いらない
End Sub

Private Sub CommandButton2_Click()
Unload Me
End Sub

Private Sub ListBox1_Click()
Me.TextBox1.Value = Me.ListBox1.Value
End Sub

Private Sub UserForm_Initialize()
With Me.ListBox1
.AddItem "53,1050,2050,5050"
.AddItem "67,890,1210,560,458"
.AddItem "478,59,1506"
End With
UserForm1.Caption = "行の選択/指定"
End Sub

お礼

ご協力感謝します、Kkkkkm さん。

自分で作りますか？を選択し、自分で作った物は保存をし次からの選択肢に加えることもできますか？そうであれば嬉しいです。

回答No.12

kkkkkm

> 指定した行番数の１通りをダイアログボックスに貯めて置いて、次から貯めて置いた何通りかから選択できる

具体的にどのようなことかがわかりません。一通りとか貯めるとか貯めて置いた何通りとか。

お礼

＞No5のおまけ。

質問中に行の選び方の説明がなかったので
No5では行をマクロの中で指定していましたが、たとえば

'SRow = Array(53, 1050, 2050)

を外して以下のように変更したらInputBoxで行を好きなだけ指定できます。

InputBoxのボックスに
53,1050,2050,5050
のように指定します。＜

をInputBoxのボックスに
・53,1050,2050,5050
・67,890,1210,560,458
・478,59,1506
「これ等の内からどれを使いますか？それとも自分で作りますか？」
のような感じで伝わりますかね？

回答No.11

kkkkkm

No5のおまけ。

質問中に行の選び方の説明がなかったので
No5では行をマクロの中で指定していましたが、たとえば

'SRow = Array(53, 1050, 2050)

を外して以下のように変更したらInputBoxで行を好きなだけ指定できます。

InputBoxのボックスに
53,1050,2050,5050
のように指定します。

SRow() As Variant
を
SRow As Variant
に変更し
Dim InputStr As String
を追加して

InputStr = Application.InputBox(Prompt:="行を入力してください。" & vbCrLf & "複数の場合はカンマ区切りで。", Type:=2)
If InputStr = "False" Then Exit Sub
SRow = Split(InputStr, ",")

For i = LBound(SRow) To UBound(SRow)
If SRow(i) < 53 Or SRow(i) > 9950 Then
MsgBox SRow(i) & " は指定可能範囲から外れています。", vbCritical
Exit Sub
End If
Next

お礼

ありがとうございますkkkkkm さん。こちらぶっ倒れてました。
ついでなんですが、指定した行番数の１通りをダイアログボックスに貯めて置いて、次から貯めて置いた何通りかから選択できるようにってできますでしょうか？

回答No.10

msMike

クレジットカードでの支払い方式の一つの「リボ払い」の「リボ」の原語は「リボルビング」ですよね。「リボルビング払い」の意味は“所謂分割払い”かと。
「リボルビングコピペ」とは初耳ですが、一体全体だう云ふ意味ですか？其れ、貴方自身の造語ですか？それとも、どの業界で馴染みの用語ですか？

お礼

次元大介の銃のリボルバーから連想しました。

回答No.9

masnoske

> 何個か行番数を選びます
この選んだ何個かの番号と，

> O4:BL4の範囲から下に向かって6000行程繰り返してコピペ
この関係が全く判りません．

> リボルバーみたいに回転してコピペする
これを勝手にスロットみたいに回転すると解釈して
以下の仮定の下に作ってみました．

仮定A: 何個か選んだ行番数をセルN4以下に記述する（52以上, 9951以下の値）．これは質問者が設定する．
仮定B: N列の値に基づいてスロットのように O:BL列にコピーする．

以下の手順でsheet8に数式を入力する．
(1) セルN3に 0を入力する（回転カウンター）．
(2) セルN4に 52以上, 9951以下の値を入力する．
(3) セルO4に以下の数式を入力する．
=INDIRECT(ADDRESS($N4+(15-COLUMN())+$N$3,3))
(4) セルO4の数式を P4:BL4にコピーする．
(5) N5以下「何個か行番数」を入力する（52以上, 9951以下の値）．
(6) O4:BL4を O5:BL5以下にコピーする．
(7) 以下のマクロを sheet8に記述する．
'－－－－－　ここから　－－－－－－－－－－－－－－－－－－
Public Sub リボルバーコピー()
Const COUNT_MAX = 6000 ' 6000行程度は適当に設定してください

Dim cnt As Long

cnt = 0
Do
Range("N3").Value = cnt
Me.Calculate

' ワークシート関数の計算が終了するまで待機
If Not Application.CalculationState = xlDone Then
DoEvents
End If

cnt = (cnt + 1) Mod COUNT_MAX
Loop
End Sub
'－－－－－　ここまで　－－－－－－－－－－－－－－－－－－
(8) sheet8 にマクロボタンを設置して (7)のマクロを登録する．
(9) マクロボタンをクリックするとスロットのように無限ループで回転を続ける．
(10) ループを停止させるのは Breakキー（ または Ctrl + Pause）.

N3，N4セルを使用している場合は，空いているセルを使用するように (1)(2) および (7) の Range("N3").Value = cnt を変更してください．

回答No.8

masnoske

No.6 です．
> 選ばれた行番数から50行戻った所までの範囲の記号値を横化して
50行戻るということは，上方向にということなので No.7訂正も含めて以下のように再訂正します．

(1) sheet8 の O1セルに以下の数式を入力する．
O1セルが使用されている場合は，他のセルでも構わない．
=RANDBETWEEN(52,9951)

(2) sheet8 の O4セルに以下の数式を入力する．
=INDIRECT(ADDRESS($O$1+(15-COLUMN())+(ROW()-4),3))
O1セル以外に (1)の数式を入力した場合は，上記の $O$1をそのセルに書き換えてください．

(3) O4セルの数式を O4:BL3003にコピーする．

(4) 以下のマクロを sheet8に記述する．
' －－－－－　ここから　－－－－－－－－－－－－－－
Public Sub 再計算()
Me.Calculate
End Sub
' －－－－－　ここまで　－－－－－－－－－－－－－－

(5) sheet8にマクロボタンを設置して (4)のコードを登録．
(6) マクロボタンをクリックする度に再計算される．