VBA 類似シート名 処理

質問

シート名が、「一覧 (2)」、「一覧 (3)」、・・・・・「一覧 (n)」、と連続する各シートの表データを「一覧」という名前のシートにまとめたいのですが、やり方が分かりません。

For Each を使えば出来るんじゃないかと調べましたが、見付けられませんでした。

シート処理以外は、

　　Dim CoR As Long, PaR As Long, PaR2 As Long

CoR = Worksheets(???).Cells(Rows.Count, 1).End(xlUp).Row
PaR = Worksheets("一覧").Range(Rows.Count, 1).End(xlUp).Row
PaR2 = CoR + PaR + 1
Worksheets(???).Range(Cells(2, 1), Cells(CoR, 12)).Copy
Worksheets("一覧").Range(Cells(PaR, 1), Cells(PaR2, 12)).PasteSpecial Paste:=xlPasteValues

こんな感じで作っています。

作り方、もしくは参考になるサイトがありましたら、教えていただければありがたいです。
よろしくお願いします。

回答No.2

cj_mover · ベストアンサー

こんにちは。お邪魔します。

> For Each を使えば出来るんじゃないかと調べましたが、見付けられませんでした。

必要なパーツそれぞれは簡易なものです。
組み合わせて使うことで少し難しくなりますし、
そのものズバリを掲載しているサイトは期待薄、ということなのでしょう。
"作り方"で答えたい気持ちはあるのですが、
パーツの組み合わせで覚えないと意味がないものは
ズバリで答えるしかないので。

For Each...Next ループを使おうというセンスは正しいと思います。
シート名をLike演算子で条件分岐します。

　If Sheets(any).Name Like "一覧 (#)" Or Sheets(any).Name Like "一覧 (##)" Then
と書いて
# 部分に一文字の半角数字を当て嵌めて文字列の比較をしています。
「一覧 (0)」から「一覧 (9)」まで「一覧 (00)」から「一覧 (99)」
一応、こちらとしては「一覧 (マスタ)」のような
ありがちなシート名を弾くことも想定しています。

　sWshNm = StrConv(oWsh.Name, vbNarrow)
について
手作業でシート名を入力していたりすると、思わぬことも起こりますので
　一覧 (39)
　一覧 (３９)
　一覧 （39）
　一覧 （３９）
などでもヒットするようにしています（よくある普通の手当てです）。

　sWshNm = StrConv(oWsh.Name, vbNarrow)
に続けて
sWshNm = Replace(sWshNm, " ", "")
と書き足して、スペースを抜いた形で比較する方が好いかも知れません。

他、
張り付ける行位置は、毎回検索しなくても加算でいけたり、
ある程度効率的にできる部分は、こちらで書き換えました。

Like 演算子については、ＶＢＡヘルプを眺める位でもいいと思います。
何か疑問がありましたら、補足欄にでも書いてみてください。

サンプルは、b、a、２パターンです。

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

Sub Re8078570b() ' b 既存データの下の行に続けて連続出力する場合
　　Dim oWsh As Worksheet ' For Each...Next ループ用ポインタ
　　Dim sWshNm As String ' 各シート名
　　Dim nPrintPos As Long ' Sheets("一覧")の書き出し行位置（変動）
　　Dim tnAppRows As Long ' Application既定の行数（固定）
　　Dim nYSize As Long ' コピー元の行数

' ' Application のウィンドウ描画更新抑止
　　Application.ScreenUpdating = False
' ' Application既定の行数を取得（２回以上使う値は変数に）
　　tnAppRows = Rows.Count

' ' Sheets("一覧")のＡ列だけをポイントしておく
　　With Sheets("一覧").Columns(1)

' ' 一覧書き出し開始行を取得
　　　　nPrintPos = .Cells(tnAppRows).End(xlUp).Row + 1
' ' Worksheetsを For Each...Next で総なめ
　　　　For Each oWsh In Worksheets

' ' 各シート名取得（２回以上使う値は変数に）（全半角混在対策で半角に統一）
　　　　　　sWshNm = StrConv(oWsh.Name, vbNarrow)
' ' Like演算子で "一覧 (#)" "一覧 (##)" 0-99の数字に対応したシートを判別
　　　　　　If sWshNm Like "一覧 (#)" Or sWshNm Like "一覧 (##)" Then

' ' 各シート、コピー元の行数取得
　　　　　　　　nYSize = oWsh.Cells(tnAppRows, 1).End(xlUp).Row - 1
' ' 各シート、コピー元に有意なデータがあるなら
　　　　　　　　If nYSize > 0 Then

' ' 各シート、コピー実行（A:L列*nYSize）
　　　　　　　　　　oWsh.Range("A2:L2").Resize(nYSize).Copy
' ' ◆エラー制御、検討が必要な行（貼り付け先の行、足りてる？）
' ' 値のみ貼り付け実行（Sheets("一覧")のＡ列のnPrintPos行にあるセル）
　　　　　　　　　　.Cells(nPrintPos).PasteSpecial Paste:=xlPasteValues
' ' 書き出し行位置にコピー元の行数を加算
　　　　　　　　　　nPrintPos = nPrintPos + nYSize
　　　　　　　　End If
　　　　　　End If ' sWshNm Like "一覧 (#)" Or
　　　　Next ' oWsh In Worksheets
　　End With

' ' Application のコピーモード終了
　　Application.CutCopyMode = False
' ' Application のウィンドウ描画更新再開（プロシージャの最後では省略可）
　　Application.ScreenUpdating = True
End Sub

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

Sub Re8078570a() ' a 既存データに上書きして固定行以下に連続出力する場合
　　Dim oWsh As Worksheet ' For Each...Next ループ用ポインタ
　　Dim sWshNm As String ' 各シート名
　　Dim nPrintPos As Long ' Sheets("一覧")の書き出し行位置（変動）
　　Dim tnAppRows As Long ' Application既定の行数（固定）
　　Dim nBottom As Long ' Sheets("一覧")の既存データの最下行
　　Dim nYSize As Long ' コピー元の行数

' ' Application のウィンドウ描画更新抑止
　　Application.ScreenUpdating = False
' 一覧書き出し開始行を指定
　　nPrintPos = 2
' ' Application既定の行数を取得（２回以上使う値は変数に）
　　tnAppRows = Rows.Count

' ' Sheets("一覧")のＡ列だけをポイントしておく
　　With Sheets("一覧").Columns(1)

' ' 既存データの最下行取得
　　　　nBottom = .Cells(tnAppRows).End(xlUp).Row
' ' 既存データをクリア
　　　　If nBottom >= nPrintPos Then
　　　　　　.Cells(nPrintPos).Resize(nBottom - nPrintPos + 1).ClearContents
　　　　End If
' ' Worksheetsを For Each...Next で総なめ
　　　　For Each oWsh In Worksheets

' ' 各シート名取得（２回以上使う値は変数に）（全半角混在対策で半角に統一）
　　　　　　sWshNm = StrConv(oWsh.Name, vbNarrow)
' ' Like演算子で "一覧 (#)" "一覧 (##)" 0-99の数字に対応したシートを判別
　　　　　　If sWshNm Like "一覧 (#)" Or sWshNm Like "一覧 (##)" Then

' ' 各シート、コピー元の行数取得
　　　　　　　　nYSize = oWsh.Cells(tnAppRows, 1).End(xlUp).Row - 1
' ' 各シート、コピー元に有意なデータがあるなら
　　　　　　　　If nYSize > 0 Then

' ' 各シート、コピー実行（A:L列*nYSize）
　　　　　　　　　　oWsh.Range("A2:L2").Resize(nYSize).Copy
' ' ◆エラー制御、検討が必要な行（貼り付け先の行、足りてる？）
' ' 値のみ貼り付け実行（Sheets("一覧")のＡ列のnPrintPos行にあるセル）
　　　　　　　　　　.Cells(nPrintPos).PasteSpecial Paste:=xlPasteValues
' ' 書き出し行位置にコピー元の行数を加算
　　　　　　　　　　nPrintPos = nPrintPos + nYSize
　　　　　　　　End If
　　　　　　End If
　　　　Next ' For Each oWsh In Worksheets
　　End With

' ' Application のコピーモード終了
　　Application.CutCopyMode = False
' ' Application のウィンドウ描画更新再開（プロシージャの最後では省略可）
　　Application.ScreenUpdating = True
End Sub

回答No.3

cj_mover

すみません。
夢の中でポカしていたことに気が付きました。

Sub Re8078570a()　についての一部訂正です。

誤）
｜' ' 既存データをクリア
｜　　　　If nBottom >= nPrintPos Then
｜　　　　　　.Cells(nPrintPos).Resize(nBottom - nPrintPos + 1).ClearContents
｜　　　　End If

正）
' ' 既存データをクリア
　　　　If nBottom >= nPrintPos Then
　　　　　　.Cells(nPrintPos).Resize(nBottom - nPrintPos + 1, 12).ClearContents
　　　　End If

それから、少し説明が雑だったようなので、、、。

> 　sWshNm = StrConv(oWsh.Name, vbNarrow)
> に続けて
> sWshNm = Replace(sWshNm, " ", "")
> と書き足して、スペースを抜いた形で比較する方が好いかも知れません。

b、a、２パターン共通で、

' ' 各シート名取得（２回以上使う値は変数に）（全半角混在対策で半角に統一）
　　　　　　sWshNm = StrConv(oWsh.Name, vbNarrow)
' ' 各シート名の中のスペースに過不足がある場合を想定してスペースを抜いて比較。
　　　　　　sWshNm = Replace(sWshNm, " ", "")
' ' Like演算子で "一覧 (#)" "一覧 (##)" 0-99の数字に対応したシートを判別
　　　　　　If sWshNm Like "一覧(#)" Or sWshNm Like "一覧(##)" Then

という意味のことを書きましたが、不明瞭でした。

全半角やスペースの有無の入力時錯誤、この手の対処は私自身多くの経験があります。
職場によっては全く必要ない場合もありますし、
保険を掛ける意味でＶＢＡの確度を高めようとする場合もあります。
シート名の判別をより正確にしたい場合などは正規表現（RegExp）を使うニーズもあるでしょう。

「一覧 (0)」というシートがあって、それだけはコピーしたくない、
なんてニーズもあるかも知れません。

何か不足があったら補足欄にでも書いてみてください。

訂正の件。失礼しました。

お礼

夢の中まで、本当にありがとうございます。

回答No.1

tom04

こんにちは！

標準モジュールにコピー＆ペーストしてマクロを実行してみてください。

Sub Sample1()
Dim i As Long, k As Long
For k = 1 To Worksheets.Count
With Worksheets(k)
If .Name <> "一覧" And InStr(.Name, "一覧") > 0 Then
i = .Cells(Rows.Count, 1).End(xlUp).Row
Range(.Cells(2, 1), .Cells(i, 12)).Copy
Worksheets("一覧").Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End If
End With
Next k
End Sub

こんな感じでよろしいのでしょうか？
外していたらごめんなさいね。m(_ _)m