エクセルマクロで流し込み書き出しはできますか？

質問

エクセルでSheet1,2,3に入っている値を加工してSheet3に書き出すマクロを作りたいと思っています。
特にSheet1と2には縦一列にデータが並んでおり、それらを結合したいのですが個数が不特定のため困っています。

例えば
Sheet1には縦1列に
10
11
12
13
・
・
・
と数値が並んでおり、

Sheet2には縦1列に
a1
a2
a3
a4
・
・
・
と文字が並んでおり、

Sheet3には
固定文字列1
固定文字列2
が記載されています。

これらを組み合わせて、

固定文字列1 10,11,12,13 固定文字列2 ('a1','a2','a3','a4')

という文字列をSheet4に書き出したいのですがマクロでどのように記述すればよいでしょうか。
数値も文字も個数は変動するので、何個であったとしても対応可能にしたいです。
数値はカンマ区切り、文字はアポストロフィ区切りで全体を括弧で囲みたいです。

また文字の個数は1000を超える場合もあるため、
固定文字列1 10,11,12,13 固定文字列2 ('a1','a2','a3','a3',・・・'a100')
固定文字列1 10,11,12,13 固定文字列2 ('a101','a102','a103','a104',・・・'a200')
固定文字列1 10,11,12,13 固定文字列2 ('a201','a202')
のように100個毎に区切りたいです。

これを吐き出すマクロ作りたいのですがご存知の方、ご教授いただけますでしょうか。

回答No.2

cj_mover · ベストアンサー

こんにちは。＃１、ｃｊ、追加レスです。

コンサバ版を書いてみましたので、説明コメント付きであげておきます。
コツコツとマメに手数の多い書き方ですから、
場合によっては処理が少し遅くなりますが、
技術的には初級のもので揃えましたから、
メンテナンスはより易しいと思います。
"A1"と"A"の箇所だけ見ていけばセル範囲指定の変更も楽にできます。
Ｂ列に変更するなら"B1"とか"B"とか、
先頭行を２行めにするなら"A2"とか、、、。

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
' ' 標準モジュール専用
Sub Re8212645c()
　　Dim r As Range　　　　' ループ用　セル範囲
　　Dim sBuf1 As String　 ' Sheet1数値を文字列として流し込みながらカンマ区切り
　　　　　　　　　　　　　' "固定文字列1_カンマ区切り文字列_固定文字列2_("
　　Dim sBuf2 As String　 ' Sheet2文字列を'文字列'カンマ区切りで整形連結
　　Dim cnR As Long　　　 ' Sheet2文字列の件数をカウント
　　Dim nPRow As Long　　 ' 出力行位置
' '　―――――――――――――――――――――――――――――

' '　―――――――――――――――――――――――――――――
' ' Sheet1　Ａ列に数値がある
　　With Sheets("Sheet1")
　　' ' Ａ列、１行めから最下行までループ
　　　　For Each r In .Range("A1", .Cells(Rows.Count, "A").End(xlUp))
　　　　' ' 各セル数値を文字列としてsBuf1に流し込みながらカンマ区切り
　　　　　　sBuf1 = sBuf1 & "," & r.Text
　　　　Next r
　　End With
' ' 先頭１文字を半角スペースに置換
　　Mid(sBuf1, 1) = " "
' '　―――――――――――――――――――――――――――――

' '　―――――――――――――――――――――――――――――
' ' Sheet3　Ａ１に固定文字列1、Ａ２に固定文字列2
　　With Sheets("Sheet3")
　　' ' 文字列連結　"固定文字列1_カンマ区切り文字列_固定文字列_("
　　　　sBuf1 = .Range("A1").Text & sBuf1 & " " & .Range("A2").Text & " ("
　　End With
' '　―――――――――――――――――――――――――――――

' ' Excel　描画更新中止
　　Application.ScreenUpdating = False

' '　―――――――――――――――――――――――――――――
' ' Sheet4　出力先シートを選択
　　Sheets("Sheet4").Select
' '　―――――――――――――――――――――――――――――

' '　―――――――――――――――――――――――――――――
' ' Sheet2　Ａ列に文字列がある
　　With Sheets("Sheet2")
　　' ' Ａ列、１行めから最下行までループ
　　　　For Each r In .Range("A1", .Cells(Rows.Count, "A").End(xlUp))
　　　　' ' 各セル文字列をsBuf2に流し込みながら整形
　　　　' ' カンマ区切り　シングルクォートで括る　→　,'文字列'
　　　　　　sBuf2 = sBuf2 & ",'" & r.Text & "'"
　　　　' ' 流し込む文字列の件数をカウント
　　　　　　cnR = cnR + 1
　　　　' ' 100件毎に
　　　　　　If cnR Mod 100 = 0 Then
　　　　　　' ' 出力行位置を１増
　　　　　　　　nPRow = nPRow + 1
　　　　　　' ' 出力
　　　　　　　　Cells(nPRow, "A") = sBuf1 & Mid$(sBuf2, 2) & ")"
　　　　　　' ' 流し込む文字列変数を空にする
　　　　　　　　sBuf2 = ""
　　　　　　End If
　　　　Next
　　' ' 100件毎で、余りがあれば（以下、同上）
　　　　If cnR Mod 100 > 0 Then
　　　　　　nPRow = nPRow + 1
　　　　　　Cells(nPRow, "A") = sBuf1 & Mid$(sBuf2, 2) & ")"
　　　　End If
　　End With
' '　―――――――――――――――――――――――――――――

' ' Excel　描画更新再開
　　Application.ScreenUpdating = True
End Sub

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

お礼

貴重なお時間を割いていただいてありがとうございます。
参考となるソースだけでありがたいのに、
ご親切に分かりやすくしていただいたので、
カスタマイズ、微調整しやすく完璧です。

ありがとうございました。

回答No.1

cj_mover

Sub Re8212645()
　　Dim v
　　Dim sBuf As String
　　Dim sCsv As String
　　Dim nBtm As Long
　　Dim i As Long

　　With Sheets("Sheet1")
　　　　For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
　　　　　　sBuf = sBuf & "," & .Cells(i, 1)
　　　　Next i
　　End With
　　Mid(sBuf, 1) = " "

　　With Sheets("Sheet3")
　　　　sBuf = .Cells(1, 1) & sBuf & " " & .Cells(2, 1) & " ("
　　End With

　　With Sheets("Sheet2")
　　　　nBtm = .Cells(Rows.Count, 1).End(xlUp).Row
　　　　v = .Cells(1, 1).Resize(nBtm).Value
　　End With
　　v = Application.Text(v, "'@'")
　　v = Application.Transpose(v)
　　sCsv = Join(v, ",")
　　For i = 100 To nBtm - 1 Step 100
　　　　sCsv = Application.Substitute(sCsv, ",", vbCrLf, i + 1 - i \ 100)
　　Next i
　　v = Split(sCsv, vbCrLf)

　　Application.ScreenUpdating = False
　　Sheets("Sheet4").Select
　　For i = 0 To UBound(v)
　　　　Cells(i + 1, 1) = sBuf & v(i) & ")"
　　Next i
　　Application.ScreenUpdating = True
End Sub

説明がない部分は勝手に補っていますから、
実際のシートデザインに合わせて修正してください。
例示が正しいという前提で半角スペースを挟んでいます。
セル範囲はすべてＡ列１行めから下へ、という仮の設定で書いています。
修正が手に余るようでしたら、具体的に補足してみて下さい。
迷わず書ける説明でしたら再レスします。

お礼

ありがとうございます。
週末か遅くとも月曜日には確認し、コメントしさせていただきます。