VBAの勉強を始めてみた

色々試しています。

複数シートを1シートにまとめる

今回のコードは前回作ったコードの出がらしリサイクルです。
前回は複数ブックのデータを一つのブックのシートにまとめるというものでしたが、今回は複数ブックという部分が、複数シートに変わっただけです。 

前回の記事を投稿して、1日経って、冷静になってコードを見直してみたら

 

は?(@_@;)何じゃこりゃ・・・・・・!

 

って感じで、色んなアラが見えてきたので(毎回、そんな感じなんですけど)

今回は、前回のコードからお節介機能を取り除き、無駄な処理を消し、同じ処理を別の表現で書けないか見直し、なるべくコンパクトにしました(したつもり)

 

マクロでやりたいことは下記のようなことです。

シートa、シートb、シートc、シートd・・・・・・のように行数が不定な複数シートがあり、

この中から「Shift」キー(または「Ctrl」キー)を押しながら選択したシートのデータを、自動的に新規追加されたシートにまとめるというものです。

イメージはこんなの(なんか、見た目気持ち悪くなってしまった) 

f:id:kouten0430:20180501230900j:plain

 

ここで、選択されたシートをループ処理するために、前々々回の記事で書いた、ActiveWindow.SelectedSheetsというプロパティが活躍します。 

kouten0430.hatenablog.com

 学んだことは1個も無駄にはならないのです、すべては伏線になっており、いつか回収されるようになっているのですよ(←ぇ)

 

Sub 複数シートを1シートにまとめる()
    '「Ctrl」キー(または「Shift」キー)を押しながら、複数選択したシートを1シートにまとめます。
    'テンプレートを元にして新規シートを1枚自動作成し、選択されているシートのデータを下方向に挿入していきます。
    'まとめるシートはすべて同じ様式であることを想定しています。
    Dim mySWs As Sheets
    Dim myTWs As Worksheet
    Dim myNWs As Worksheet
    Dim yr As Range
    Dim y As Long
    Dim x As Integer
    Dim myWs As Worksheet
    Dim cye As Long
    Dim pye As Long
    Dim ctp As Integer
    Dim ct As Integer
    
retry:
        On Error Resume Next
    
        Set yr = Nothing 'retryした時のためのリセット

        Set yr = Application.InputBox(Prompt:="テンプレートとなるシートで、見出しの1行下を選択し、" & vbCrLf & _
        "OKして下さい。", Type:=8)
            If yr Is Nothing Then    'キャンセルを押された場合の処理
                Exit Sub
            ElseIf yr.Resize(1, 1).Value = "" Then  '複数範囲を選択された場合も想定して、Resizeを適用する
                MsgBox "空白以外のセルを選択してください。"
                GoTo retry
            End If

        On Error GoTo 0
        
    
    Set mySWs = ActiveWindow.SelectedSheets 'マクロ実行前に選択されているシート
    
    Set myTWs = Worksheets(yr.Parent.Name) 'テンプレートとなるシート
    
    myTWs.Copy Before:=Worksheets(1)
    Set myNWs = Worksheets(1)   'テンプレートを元に新規作成されたシート
    
    Application.ScreenUpdating = False  '画面表示の更新をオフにする
    
    y = yr.Row  'yrから行を取得
    x = yr.Column   'yrから列を取得

    For Each myWs In mySWs
        If myTWs.Name <> myWs.Name And myWs.ProtectContents = False Then  'テンプレートとなるシート、保護されたシート以外を処理する
            If Not myWs.AutoFilter Is Nothing Then   'コピーするシートにオートフィルターが設定されている場合は解除する
                myWs.Cells(y, x).AutoFilter
            End If
        
            cye = myWs.Cells(y, x).CurrentRegion.Rows(myWs.Cells(y, x).CurrentRegion.Rows.Count).Row
            pye = myNWs.Cells(y, x).CurrentRegion.Rows(myNWs.Cells(y, x).CurrentRegion.Rows.Count).Row
        
            myWs.Rows(y & ":" & cye).Copy
            myNWs.Rows(pye + 1).Insert
            myWs.Application.CutCopyMode = False  'コピーモードを解除する
        
        ElseIf myWs.ProtectContents Then
            ctp = ctp + 1

        End If

        ct = ct + 1
        Application.StatusBar = "処理実行中..." & ct & "/" & mySWs.Count
        
    Next myWs
    
    
    MsgBox "処理成功:" & ct - ctp & "/" & mySWs.Count & vbCrLf & "保護シート:" & ctp
    
    Application.StatusBar = False

End Sub

※SubからEnd Subまでをコピーし、標準モジュール等に貼り付けて使用して下さい。なお、マクロで実行した処理は「元に戻す」ことができません。実行前に一旦保存しやり直しのできる状態にしておいて下さい。標準モジュールにコードを貼り付けてマクロを使用する方法はこちら。 


独学というのはやっかいなもので、間違った方向に向かっていたとしても、自分では気がつきにくいものなのです。
日を改めて、冷静になって振り返った時に「これは変だ・・・・・・」と思うことぐらいが、唯一の羅針盤になるんでしょうか。


という今回掲載したコードだって、明日になって見れば

は?(@_@;)何じゃこりゃ・・・・・・!

って思うことは間違いない。