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.7

masnoske

No.6 です．
以下のように訂正します．

誤：(5) sheet8にマクロボタンを設置して (2)のコードを登録．
正：(5) sheet8にマクロボタンを設置して (4)のコードを登録．

回答No.6

masnoske

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

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

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

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

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

回答No.5

kkkkkm

複数行を指定した場合

たとえば、53行目、1050目、2050目

No1の複数の行番号指定

Sub Test3()
Dim buf As Variant, SRow() As Variant
Dim i As Long, k As Long, j As Long: j = 0

SRow = Array(53, 1050, 2050)

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
End Sub

No3の複数の行番号指定

Sub Test4()
Dim buf As Variant, tmp As Variant, SRow() As Variant
Dim i As Long, k As Long, j As Long

SRow = Array(53, 1050, 2050)

With Sheets("Sheet8")
.Cells(4, "O").Resize(6003, 50).ClearContents
For i = LBound(SRow) To UBound(SRow)
buf = .Range(.Cells(SRow(i) - 50, "C"), .Cells(SRow(i), "C")).Value
.Cells(4 + i, "O").Resize(1, 50).Value = WorksheetFunction.Transpose(buf)
For k = 4 + UBound(SRow) + 1 To 6003 Step UBound(SRow) - LBound(SRow) + 1
tmp = buf(LBound(buf, 1), 1)
For j = LBound(buf, 1) To UBound(buf, 1) - 1
buf(j, 1) = buf(j + 1, 1)
Next
buf(UBound(buf, 1), 1) = tmp
.Cells(k + i, "O").Resize(1, 50).Value = WorksheetFunction.Transpose(buf)
Next
Next
End With
End Sub

回答No.4

masnoske

> 何個か行番数を選びます。
「何個か」というのは，どうやって決めるのでしょうか．
あなたが決めるのか，自動で決めるのかが不明です．
また選ぶという行為も，あなたが選ぶのか，自動で選ぶのかが不明です．

> O4:BL4の範囲から下に向かって6000行程繰り返してコピペしたいです。
6000行程とありますが，繰返し回数をどうやって決めるのでしょうか．あなたが決めるのか，自動で決めるのかが不明です．
また，どの範囲で行数を決めるのかが規定されていません．
たとえば 6000±100行 のように．

以上の曖昧な部分をご提示ください．

回答No.3

kkkkkm

No2は最初の範囲がコピペされないので訂正

Sub Test2()
Dim buf As Variant, tmp As Variant
Dim i As Long, k As Long, j As Long

i = 53

With Sheets("Sheet8")
.Cells(4, "O").Resize(6003, 50).ClearContents
buf = .Range(.Cells(i - 50, "C"), .Cells(i, "C")).Value
.Cells(4, "O").Resize(1, 50).Value = WorksheetFunction.Transpose(buf)
For k = 5 To 6003
tmp = buf(LBound(buf, 1), 1)
For j = LBound(buf, 1) To UBound(buf, 1) - 1
buf(j, 1) = buf(j + 1, 1)
Next
buf(UBound(buf, 1), 1) = tmp
.Cells(k, "O").Resize(1, 50).Value = WorksheetFunction.Transpose(buf)
i = i + 1
Next
End With
End Sub

回答No.2

kkkkkm

No1は50個の範囲をスライドさせていきますが

> リボルバーみたいに回転してコピペ

50個の範囲で自転していくということだとしたら

Sub Test2()
Dim buf As Variant, tmp As Variant
Dim i As Long, k As Long, j As Long

i = 53

With Sheets("Sheet8")
.Cells(4, "O").Resize(6003, 50).ClearContents
buf = .Range(.Cells(i - 50, "C"), .Cells(i, "C")).Value
For k = 4 To 6003
tmp = buf(LBound(buf, 1), 1)
For j = LBound(buf, 1) To UBound(buf, 1) - 1
buf(j, 1) = buf(j + 1, 1)
Next
buf(UBound(buf, 1), 1) = tmp
.Cells(k, "O").Resize(1, 50).Value = WorksheetFunction.Transpose(buf)
i = i + 1
Next
End With
End Sub

回答No.1

kkkkkm

> 何個か行番数を選びます。

とりあえず1個だけ53行目(50戻るので最低は53行目)を選んだとして、選択範囲(50行分)を一行ずつ下にずらしながら6000行分コピペ

Sub Test()
Dim buf As Variant
Dim i As Long, k As Long

i = 53

With Sheets("Sheet8")
.Cells(4, "O").Resize(6003, 50).ClearContents
For k = 4 To 6003
buf = .Range(.Cells(i - 50, "C"), .Cells(i, "C")).Value
.Cells(k, "O").Resize(1, 50).Value = WorksheetFunction.Transpose(buf)
i = i + 1
Next
End With
End Sub