[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『A列の文字列でB列の数字繰り返し連番を付けて別シートに一覧作成』(yk)
お世話になります。
VBA初心者です。
サンプルを探しながら試行錯誤してるのですが、解決方法がうまく探せませんでした。
【やりたいこと】
●Sheet1----------------
A列 B列
aaa 3
bbb 5
のようなシート(使用する行数は固定ではなく、使用時により変動します)から
●Sheet2(理想の形)-------------------
A列
aaa.jpg
aaa_1.jpg
aaa_2.jpg
bbb.jpg
bbb_1.jpg
bbb_2.jpg
bbb_3.jpg
bbb_4.jpg
という一覧が出せるVBAを作りたいところでした。
Sheet1の
各行B列の数だけ繰り返される形で、
最初は A列の文字列.jpg、次以降は _連番.jpg となる形です。
連番が入らないけどsheet2に行が増やせたサンプル---------------------------
Sub Sample1()
Dim i As Long, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
wS2.Range("A:A").ClearContents
On Error Resume Next
For i = 1 To wS1.Cells(Rows.Count, "A").End(xlUp).Row
wS2.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(wS1.Cells(i, "B")) = wS1.Cells(i, "A") & ".jpg"
Next i
wS2.Range("A1").Delete shift:=xlUp
End Sub
どこを変えたら理想の形になりますでしょうか?
サンプルからの変更でも、全く別のVBAとなっても構いません。
宜しければ、お手数ですがアドバイスいただけると助かります。
よろしくお願いいたしますm(__)m
< 使用 Excel:Excel2013、使用 OS:Windows10 >
こんなので、ワークしないですか?
Sub Sample1() Dim i As Long, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1") Set wS2 = Worksheets("Sheet2") wS2.Range("A:A").ClearContents
'On Error Resume Next '←無意味に書かない
For i = 1 To wS1.Cells(Rows.Count, "A").End(xlUp).Row With wS2.Cells(Rows.Count, "A").End(xlUp).Offset(1) .Value = wS1.Cells(i, "A") & "_0.jpg" If wS1.Cells(i, "B") > 1 Then .AutoFill Destination:=.Resize(wS1.Cells(i, "B")) End If End With Next i
wS2.Range("A1").Delete shift:=xlUp wS2.Columns("A:A").Replace What:="_0.jpg", Replacement:=".jpg", LookAt:=xlPart End Sub
(半平太) 2018/03/13(火) 22:24
ちょっと書いてみました。 Option Explicit Sub Sample1() Dim wS1 As Worksheet, wS2 As Worksheet Dim MyA As Variant Dim MyAry() As Variant Dim i As Long Dim x As Long Dim r As Long Dim k As Long Dim n As Long Dim MyFlg As Boolean Set wS1 = Worksheets("Sheet1") Set wS2 = Worksheets("Sheet2") With wS1 MyA = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 2).Value End With For i = LBound(MyA, 1) To UBound(MyA, 1) x = x + Val(MyA(i, UBound(MyA, 2))) Next ReDim MyAry(1 To x) For i = 1 To UBound(MyA, 1) k = 1 MyFlg = False For r = 1 To MyA(i, 2) n = n + 1 If MyFlg = False Then MyAry(n) = MyA(i, 1) & ".jpg" MyFlg = True Else MyAry(n) = MyA(i, 1) & "_" & k & ".jpg" k = k + 1 End If Next Next With wS2 .Range("A:A").ClearContents .Range("A1").Resize(UBound(MyAry)).Value = Application.Transpose(MyAry) End With Erase MyA, MyAry End Sub v(=∩_∩=)v (SoulMan) 2018/03/13(火) 23:30
ありがとうございます!
どちらのコードもまさに私が目指していた理想の動作になりました。
いろいろな書き方があるんですね
なかなか、自分ではここまで書けないので、とても助かりました。
ありがとうございました!
(yk) 2018/03/14(水) 01:10
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.