[[20230125221949]]　『同じ文字列を複数回繰り返すには』（ブルー☆ギラヴァンツ）　ページの最後に飛ぶ

『同じ文字列を複数回繰り返すには』（ブルー☆ギラヴァンツ）

いつもお世話になっております
りんご
バナナ
スイカ
となっている列を
りんご
りんご
りんご
バナナ
バナナ
バナナ
スイカ
スイカ
スイカ
みたいに複数回繰り返すにはどうすればよろしいでしょうか
見本では３回ですが任意の回数繰り返す方法も教えてくださいよろしくお願いします

＜使用 Excel：Excel2019、使用 OS：Windows10 ＞

 Option Explicit
Sub OneInstanceMain()
    Dim i             As Long
    Dim j             As Long
    Dim x             As Long
    Dim n             As Long
    Dim sNm           As String
    Dim v()           As Variant
    Dim w()           As Variant
    x = 3
    With Worksheets("Sheet1")
        v = .Cells(1).CurrentRegion.Value
        .Copy after:=Worksheets(1)
        sNm = ActiveSheet.Name
    End With
    ReDim w(1 To x * UBound(v, 1), 1 To 1)
    For i = 1 To UBound(v, 1)
        For j = 1 To x
            n = n + 1
            w(n, 1) = v(i, 1)
        Next
    Next
    With Worksheets(sNm)
        .UsedRange.Clear
        .Cells(1).Resize(UBound(w, 1), UBound(w, 2)) = w
    End With
    Erase v, w
End Sub
こんな感じでせうか。＾＾；
＞＞任意の回数繰り返す方法
何らかの方法で反復回数をプロシジャーに受け取らせ、変数
xに格納してください。m(__)m
（隠居Z） 2023/01/25(水) 23:12:16

 お遊び
 InputBoxに数値以外、キャンセル、×で閉じるを行うとエラーになります。
 '■Evaluate計算式Ver
    Sub test() 
        Dim v As Variant
        Dim f As String
        Dim ws As Worksheet
        Dim rptNum As Long
        Set ws = Sheets("Sheet1")
        rptNum = InputBox("繰り返し回数", , 2)
        ws.Activate
        f = "TRANSPOSE(IF(ROW(1:■),REPT(A1:A■&"","",▲)))"
        f = Replace(f, "■", ws.Cells(Rows.Count, "A").End(xlUp).Row)
        f = Replace(f, "▲", rptNum)
        v = Evaluate(f)
        v = Join(v, "")
        v = Split(Left(v, Len(v) - 1), ",")
        With Sheets.Add(after:=Sheets(Sheets.Count))
            .[A1].Resize(UBound(v)).Value = Application.Transpose(v)
        End With
        MsgBox "新しいシートに出力しました"
    End Sub

 '■ByRef渡し、再帰処理Ver
    Sub test2()
            Dim ws As Worksheet
            Dim r As Range
            Dim rptNum As Long
            Set ws = Sheets("Sheet1")
            rptNum = InputBox("繰り返し回数", , 2)
            ReDim v(0 To 0)
            For Each r In ws.Range("A1", ws.Cells(Rows.Count, "A").End(xlUp))
                Call 文字繰り返し(v, r.Value, rptNum)
            Next r
            With Sheets.Add(after:=Sheets(Sheets.Count))
                .[A1].Resize(UBound(v)).Value = Application.Transpose(v)
            End With
            MsgBox "新しいシートに出力しました"
    End Sub
    Sub 文字繰り返し(ByRef v As Variant, ByVal moji As String, ByVal reptNum As Long, Optional cnt As Long = 1)
        ReDim Preserve v(1 To UBound(v) + 1)
        v(UBound(v)) = moji
        If reptNum > cnt Then
            Call 文字繰り返し(v, moji, reptNum, cnt + 1)
        End If
    End Sub

（稲葉） 2023/01/26(木) 08:35:54

数式案です。
A列にデータがあるとします。

他の列に： =IFERROR(INDEX($A$1:$A$3,INT((ROW(A1)-1)/3)+1),"")

必要数、下にコピーします。

＞任意の回数繰り返す方法(5回にするなら）

INT((ROW(A1)-1)/3)+1　→　INT((ROW(A1)-1)/5)+1
（メジロ） 2023/01/26(木) 08:53:55

マクロ案になりますが、下から順に

 1. 行をコピーする
 2. 指定数-1行分、コピーした行を挿入する

という処理を繰り返しても良さそうにおもいます。
この方法であれば、繰り返し部分を除き【マクロの記録】で必要な命令を調べることができるとおもいます。

よって、まずは3行目のスイカをコピーして、3～4行目に挿入する作業を【マクロの記録】でコード化してどのような命令が使われているか確認してみてはどうでしょうか？

（もこな２） 2023/01/26(木) 09:08:19

 Sub Sample()
    Dim xl As Application
    Dim rng As Range
    Dim cnt As Long
    Dim i As Long
    Set xl = Excel.Application
    On Error Resume Next
    Set rng = xl.InputBox("複写元範囲を選択してください", Type:=8)
    If rng Is Nothing Then Exit Sub
    cnt = xl.InputBox("何回繰り返しますか？", Type:=1)
    cnt = cnt - 1
    If cnt < 1 Then Exit Sub
    On Error GoTo 0
    With rng
        xl.ScreenUpdating = False
        For i = .Rows.Count To 1 Step -1
            With .Rows(i)
                .Offset(1).Resize(cnt).Insert
                .Copy .Offset(1).Resize(cnt)
            End With
        Next
        xl.CutCopyMode = False
        xl.ScreenUpdating = True
    End With
 End Sub

（こんな感じかな） 2023/01/26(木) 11:02:49

みなさんありがとうございます
解決しました
（ブルー☆ギラヴァンツ） 2023/01/26(木) 23:14:10

コメント返信：

[ 一覧(最新更新順) ]

[[20230125221949]] 『同じ文字列を複数回繰り返すには』（ブルー☆ギラヴァンツ） ページの最後に飛ぶ

[[20230125221949]]　『同じ文字列を複数回繰り返すには』（ブルー☆ギラヴァンツ）　ページの最後に飛ぶ