VLOOKUP関数的にファイルリネームを行う

VLOOKUP関数的に、いわゆる「表引き」でファイル名のリネームを行うファイルリネームソフト（もどき）を作ってみました。

目次 

概要

例えばこのように、とある商品の設計資料があったとして、ファイル名が商品コードのみであったとします。

これでは、ぱっと見、各ファイルがどの商品のものなのか分かりづらいですよね？かといって、いちいち手作業でファイル名を直していられるほど現代人は暇ではありません。なので、エクセルのリストとマクロを使ってファイル名に商品名を追記してみたいと思います。
リストが存在することが前提ですが、例えば、商品コード「1000」に一致するファイル名に、同じ行の左端からn列目（仮に2列目とする）の値を挿入し、ファイル名を「1000めぐすり」に変更します。

同じように、商品コードの列を垂直方向に検索していき、一致する同じ行のn列目の値をファイル名に挿入していきます。

こんな感じで、変更前に比べて各ファイルが何の商品のものなのか、ぱっと見で、分かりやすくなりました。

これくらいのファイル数なら、手作業でもできますが、仮に数百ファイルあった場合、手作業でやろうとすると、茨の道を歩むことになります。（試しにマクロで1,000ファイルリネームしてみたところ、1秒かからずに完了しました）

プログラムの流れ

1. どのフォルダのファイル群に対して処理を行うのかを選択します。
2. VLOOKUP関数的に「表引き」を行う矩形範囲を選択します。

   

3. 選択した範囲が下図のように配列に格納されます。（画像はイメージ）

   

4. 選択範囲の左端から数えて何列目から表引きするかを指定します。

   

5. 左端の値を用いてフォルダー内を部分一致条件で検索し、一致したファイル名を取得します。
6. Nameステートメント（Name 元のファイル名〔取得したファイル名〕　As 変更後のファイル名〔元のファイル名 + 配列のn列目の値〕）で、リネームします。
7. 5～6を二次元配列の1次元（範囲の左端）の最大値までループします。

コード本体 

Sub VLOOKUP関数的ファイルリネーム()
    Dim Dn As String
    Dim Tdim As Variant
    Dim n As Variant
    Dim i As Integer
    Dim Fn As String
    Dim p As Integer
    Dim ct As Integer
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "リネーム作業を行うフォルダーを選択して下さい"
        
        If .Show = -1 Then
            Dn = .SelectedItems(1)
        Else
            Exit Sub
        End If
    
    End With
    
    Tdim = Application.InputBox(prompt:="範囲の左端の値でファイル名を検索し、一致したファイルには、" & vbCrLf & _
    "同じ行の左端からn列目の値をファイル名の末尾に挿入します。" & vbCrLf & "（検索は部分一致で行われます）", Title:="矩形範囲を選択して下さい", _
    Type:=8) '選択された範囲を二次元配列に格納する
        If TypeName(Tdim) = "Boolean" Then  'キャンセルを押された場合の処理
            Exit Sub
        End If
        
    n = Application.InputBox(prompt:="nを指定します。（左端を1列目とします）", Title:="数値を入力して下さい", Type:=1)
        If TypeName(n) = "Boolean" Then  'キャンセルを押された場合の処理
            Exit Sub
        End If

    For i = 1 To UBound(Tdim)   '二次元配列の一次元の最大値までループ
        If Not IsEmpty(Tdim(i, 1)) Then
            Fn = Dir(Dn & "\*" & Tdim(i, 1) & "*")    'フォルダー内を部分一致条件で検索し、一致したファイル名を取得（なければ空白が返る）
        
            Do Until Fn = ""    'ファイル名が空白になるまでループ
                p = InStrRev(Fn, ".")  '.を後方から検索して最初に見つかった文字位置（先頭からの文字数）を返す
                Name Dn & "\" & Fn As Dn & "\" & Application.WorksheetFunction.Replace(Fn, p, 0, Tdim(i, n))  '元のファイル名と拡張子の間に、n列目の値を挿入する
                ct = ct + 1
                Fn = Dir()  '検索一致が複数あった場合の、二つ目以降のファイル名を取得（なければ空白が返る）
            Loop
        End If
        
    Next i
    
    MsgBox "処理成功：" & ct & " ファイル"

End Sub

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

引数なしのDir関数の振る舞い

Dir関数でファイル名を検索し、検索結果が複数あった場合のために、引数なしのDir()をループの中に配置します。
Dir()は、2個目以降の検索結果を、ループで順番に吐き出し、検索結果がなくなれば空白（長さ0の文字列）を吐き出してくれます。が、処理によっては困ったことが発生しました。
ローカルウィンドウ等で観察した上での推定ですが、Dir()は名前順でファイル名を検索しているようで、ループ処理の中で名前順が変わってしまうようなリネームを行うと、同じファイルを2度検索してしまうようなのです。
ファイル名末尾への文字挿入やファイル名すべてを変更するリネームでは、名前順が変わらない、または、2度目の検索に一致しないため問題ないようですが、ファイル名先頭への文字挿入で不具合が起こります。
同じ人が変装して、同じ列に何回も並ぶようなもの（？）でしょうか。

お好みで機能を変更する

ファイル名を部分一致ではなく、完全一致で検索したい場合は、下記の * の部分を消去します。

• 変更前：Fn = Dir(Dn & "\*" & Tdim(i, 1) & "*")
• 変更後：Fn = Dir(Dn & "\" & Tdim(i, 1))

挿入する文字の前に区切りとなる文字（アンダーバーなど）を入れるには、下記のようにします。

• 変更前：Application.WorksheetFunction.Replace(Fn, p, 0, Tdim(i, n))
• 変更後：Application.WorksheetFunction.Replace(Fn, p, 0, "_" & Tdim(i, n))

ファイル名の末尾ではなく、ファイル名全体を変更するには、pを1（ファイル名の先頭）とし、0をp-1（拡張子の手前）とします。

• 変更前：Application.WorksheetFunction.Replace(Fn, p, 0, Tdim(i, n))
• 変更後：Application.WorksheetFunction.Replace(Fn, 1, p-1, Tdim(i, n))

大量のシートから目的のシートを探して表示させる方法

エクセルを使って仕事をしていると、一つのブックにシートが多くなりすぎて、目的のシートを探すのに手間取ってしまうことがあります。
自分で作った資料ならまだしも、余所から頂いた資料であればなおさらです。
１秒を争うような場面で、目的のシートが中々見つけられないと、ほんとイライラ（ヒヤヒヤ、ドキドキ）します。
なので、大量にあるシートから目的のシートを簡単に探して、表示させる方法を紹介します。

目次

標準機能を使う方法

シートが多くなると、タブが１画面に表示しきれなくなり、左右にスクロールしなければシート名を視認することができなくなります。
このような時は、左下の三角マークの場所で右クリックすると、全シート名を一覧表示することができます。

ここからシート名を選択してＯＫすることで、目的のシートを表示することができます。

マクロを使う方法

標準機能を使った方法でも充分事足りるとは思いますが、万が一、シートが数百枚あった場合には探し出すのに少し苦労するかもしれません。
そんなときはマクロで文字列検索させましょう。

どのシートでもいいので、マクロを実行します。
Zを含むシートを検索し、表示させます。

このシートでよければ「はい」、次を検索する場合は「いいえ」を選択します。

検索に一致するものがなければ、その旨をメッセージ表示し終了します。

Sub 目的のシートを検索しアクティブにする()
    '大文字と小文字を区別しません｡
    '半角と全角を区別しません｡
    Dim sw As String
    Dim myWs As Worksheet
    Dim mb As Integer
    
    sw = InputBox("検索する文字列")
        If sw = "" Then '空白でOKした場合、キャンセルした場合の処理
            Exit Sub
        End If
    
    For Each myWs In Worksheets
        If StrConv(StrConv(myWs.Name, vbLowerCase), vbNarrow) Like "*" & _
        StrConv(StrConv(sw, vbLowerCase), vbNarrow) & "*" Then   '半角小文字に統一し、部分一致条件でシート名を検索する
            myWs.Activate
            
            mb = MsgBox(prompt:="このシートでよければ「はい」を、" & vbCrLf & _
            "次を検索するには「いいえ」を押して下さい。", Buttons:=vbYesNo)
            
            If mb = 6 Then  '「はい」を選択した場合はプロシージャを終了する
                Exit Sub
            End If
            
        End If
    Next myWs
    
    MsgBox "検索に一致するものはありませんでした。"
    
End Sub

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

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

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

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

は？(＠_＠;)何じゃこりゃ･･････！

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

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

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

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

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

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

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

kouten0430.hatenablog.com

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

Sub 複数シートを1シートにまとめる()
    '「Ctrl」キー（または「Shift」キー）を押しながら、複数選択したシートを１シートにまとめます。
    'テンプレートを元にして新規シートを１枚自動作成し、選択されているシートのデータを下方向に挿入していきます。
    'まとめるシートはすべて同じ様式であることを想定しています。
    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までをコピーし、標準モジュール等に貼り付けて使用して下さい。なお、マクロで実行した処理は「元に戻す」ことができません。実行前に一旦保存しやり直しのできる状態にしておいて下さい。標準モジュールにコードを貼り付けてマクロを使用する方法はこちら。 

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

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

は？(＠_＠;)何じゃこりゃ･･････！

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

現在アクティブなブックのシートに、複数ブックのデータを挿入貼り付けする

今回は、マクロを使い始めた人がまず最初にやってみそうなことを、やってみようかと思います。

やりたいことは単純に下記のようなこと。

a.xlsx、b.xlsx、c.xlsx、d.xlsx、･･････z.xlsxのように行数が不定な複数ブックがあり、

これらのデータを、a.xlsxのデータ群の下側に挿入貼り付けをしていくというものです。（貼り付けされる側のブックは、b.xlsx、c.xlsx･･････であってもよい）

今回のマクロの中身をざっくりと説明すると、Application.GetOpenFilenameというメソッドで、ファイル選択のためのダイアログボックスを開き、ブックを選択します（ブックは複数選択可能です）。
ここでは、a.xlsxにペーストするので、a.xlsxを除いた、b.xlsx～z.xlsxを選択。（a.xlsxは開いた状態にしておく）

ここで選択されたブックのブック名（パスを含んだFullName）が配列に格納されるため、配列の内容をFor Each　～Nextで順次読み取り

• 取得したブック名を用いてブックを開く
• ブックを開いた時にアクティブなシートのデータをコピー
• 貼り付けされる側のブックのデータ群の１行下にインサート
• 開いたブックを変更せずに閉じる

というループ処理を行います。

コピーを開始するための始点となる行はユーザーが指定する必要がありますが、終点となる行はプログラムが自動判別します。
なので、行数は不定であっても、見出しの位置や内容、列の数などは同様なデータの連結を想定しています。（そもそも、様式の異なる資料を連結しても意味ないですし。）

その他は、不具合防止のための処理などがずらずらと並んでいます。 

Sub 現在アクティブなブックに複数ブックのデータを挿入貼り付け()
    '現在アクティブなブックのデータ群の１行下に、選択されたブックのデータを、順番に挿入貼り付けしていきます。
    '対象となるのは、*.xlsx、*.xlsm、、*.csv等のエクセルで扱うことのできるファイルです。
    'ペーストされるブック（現在アクティブなブック）以外は閉じた状態で実行して下さい。
    'コピーするブックは、ペーストされる側のブックと同じ様式であることを想定しています。
    Dim awn As String
    Dim Bcdrive As String
    Dim Bcdir As String
    Dim lwfn As Variant
    Dim ctm As Integer
    Dim yr As Range
    Dim nod As Variant
    Dim anod As Long
    Dim y As Long
    Dim x As Integer
    Dim myWb As Variant
    Dim i As Integer
    Dim cts1 As Integer
    Dim lwn As String
    Dim myLis As ListObject
    Dim lye As Long
    Dim aye As Long
    Dim cts2 As Integer
    Dim ct As Integer
    
    awn = ActiveWorkbook.Name
        If Not awn Like "*.*" Then
            MsgBox "新規ブック上では実行できません。"
            Exit Sub
        End If
        
    Bcdrive = Left(CurDir, InStr(CurDir, ":") - 1)  '現在のカレントドライブを記憶
    Bcdir = CurDir  '現在のカレントディレクトリを記憶
    
    ChDrive Left(ActiveWorkbook.Path, InStr(ActiveWorkbook.Path, ":") - 1)    'カレントドライブを一時的に変更
    ChDir ActiveWorkbook.Path 'カレントディレクトリを一時的に変更
    
    lwfn = Application.GetOpenFilename(Title:="コピーするブックを選択（複数選択可）", MultiSelect:=True)
        If TypeName(lwfn) = "Boolean" Then  'キャンセルを押された場合の処理
            ChDrive Bcdrive
            ChDir Bcdir
            Exit Sub
        End If
        
    ctm = UBound(lwfn)

retry1:

    On Error Resume Next
    
    Set yr = Nothing 'retryした時のためのリセット

    Set yr = Application.InputBox(Prompt:="コピーの始点となる行のセルを選択し、OKして下さい。" & vbCrLf & "（見出しの1行下を推奨）", Type:=8)
        If yr Is Nothing Then    'キャンセルを押された場合の処理
            ChDrive Bcdrive
            ChDir Bcdir
            Exit Sub
        ElseIf yr.Resize(1, 1).Value = "" Then  '複数範囲を選択された場合も想定して、Resizeを適用する
            MsgBox "空白以外のセルを選択してください。"
            GoTo retry1
        End If

    On Error GoTo 0
    
retry2:
    
    nod = Application.InputBox(Prompt:="行×列 に含まれる、最大データ数を指定して下さい。" & vbCrLf & _
    "・コピーするブックがこの値を超えた場合、処理をスキップします。" & vbCrLf & _
    "・フリーズ防止策です。環境に応じて増減して下さい。", Default:="10000", Type:=1)
        If TypeName(nod) = "Boolean" Then  'キャンセルを押された場合の処理
            ChDrive Bcdrive
            ChDir Bcdir
            Exit Sub
        Else
            anod = WorksheetFunction.CountIf(Range("A1:XFD1048576"), "<>")
            If anod > nod Then
                MsgBox "ペーストされる側のブックに" & Format(nod, "#,###") & "を超える、" & Format(anod, "#,###") & "データが存在します。" _
                & vbCrLf & vbCrLf & "フリーズを避けるために、軽量なブック上で実行することを推奨します。" & vbCrLf & _
                "コピーする側のブックではさらにメモリを必要としますので、必要に応じ、" & vbCrLf & "最大データ数を増減して下さい。"
                GoTo retry2
            End If
        End If
    
    Application.ScreenUpdating = False  '画面表示の更新をオフにする
    
    y = yr.Row  'yrから行を取得
    x = yr.Column   'yrから列を取得
    
    If Not ActiveSheet.AutoFilter Is Nothing Then   '念のための処理１
        Cells(y, x).AutoFilter
    End If

    For Each myWb In lwfn
        For i = 1 To Workbooks.Count
            If Workbooks(i).FullName = myWb Then    '既に開いているブックは処理をスキップ
                If Not myWb Like "*" & awn Then 'ペーストされるブックはスキップにカウントしない
                    cts1 = cts1 + 1
                End If
                GoTo skip
            End If
        Next i
        
        Workbooks.Open Filename:=myWb 'ブックを開くと同時にアクティブとなる
        lwn = ActiveWorkbook.Name   'パスを含まないブック名を取得しておく
        
        If ActiveSheet.ListObjects.Count > 0 Then   '念のための処理２
            For Each myLis In ActiveSheet.ListObjects
                myLis.Unlist
            Next myLis
        End If
        
        If Not ActiveSheet.AutoFilter Is Nothing Then   '開いたブックのシートにオートフィルターが設定されている場合は解除する
            Cells(y, x).AutoFilter
        End If
        
        lye = Cells(y, x).CurrentRegion.Rows(Cells(y, x).CurrentRegion.Rows.Count).Row
            
        If WorksheetFunction.CountIf(Rows(y & ":" & lye), "<>") <= nod Then '指定した最大値以下の場合のみ処理する
        
            Rows(y & ":" & lye).Copy
        
            Workbooks(awn).Activate
            aye = Cells(y, x).CurrentRegion.Rows(Cells(y, x).CurrentRegion.Rows.Count).Row
            Rows(aye + 1).Insert
        
            Workbooks(lwn).Application.CutCopyMode = False  'コピーモードを解除する
            
        Else
        
            cts2 = cts2 + 1
            
        End If
        
        Workbooks(lwn).Close savechanges:=False
        DoEvents    'Closeが完了するまで待つ

skip:

        ct = ct + 1
        Application.StatusBar = "処理実行中．．．" & ct & "/" & ctm
        
    Next myWb
    
    ChDrive Bcdrive
    ChDir Bcdir
    
    MsgBox "処理成功：" & ct - cts1 - cts2 & "/" & ctm & vbCrLf & "スキップ：" & cts1 + cts2 & "（Open重複：" & cts1 & _
    "，最大数超過：" & cts2 & "）"
    
    Application.StatusBar = False

End Sub

このマクロの動作確認をするために、色々なブックを使ってテストしてみたんですが、データをコピーする際にデータ数があまりに多いとフリーズしてしまうようです。
私の環境では約35,000を超えるデータ（1,000行×35列にびっしりとデータが詰まっている感じ）から、動作が不安定になるので、環境によって取り扱えるデータ数を増減できるようにしてみました。（ユーザーが指定したデータ最大数を超えてコピーしようとすると、コピーせずに次のブックに処理を飛ばします）
感覚的に、同じデータ数でも、縦に長いより横に長いほうが処理が思いように感じます。
コピーする場合ほどではないにせよ、ペーストされる側のブック（常時開いたままになるブック）にデータが多い場合も、処理が重くなるように感じたので、これも先に指定した値を超えるデータを含むブックであった場合、処理できない（マクロを実行できない）ようにしました。
フリーズを避けるために、がんじがらめにしてしまいましたが、PCのスペックが高いのならば最大値を2,147,483,647（約46340行×46340列）まで拡げることもできるのではないかと思います。

補足：

• ブックを処理する順番は、ファイル選択のダイアログボックスで選択した順ではなく、ダイアログボックスでの表示順（上から）になります（要するに上から順番に配列に格納される）。なので、順番を変えたい場合は、ダイアログボックスで右クリックし、名前順・更新日時順・サイズ順などで並び替えて下さい。

  

• 処理の対象となるブックにブック保護・シート保護・セル保護などがかかっていないことを確認して下さい。
• データの下端はCurrentRegionで判定します。CurrentRegionでどのような範囲が取得されるかは、該当のセルで「Shift」＋「Ctrl」＋「*」を押せば確認することができます。（該当のセルが空白でも、隣接する8方向のいずれかにデータが存在していれば、そこから空白で囲まれたデータ郡を矩形範囲で選択します）

ブックを開く・コピーする・ペーストする・ブックを閉じるといった、人間が行う処理をマクロで原始的に行っているだけなので、数が多くなるとどうしても処理に時間がかかります。
といっても、トイレに行って戻ってくる頃には終わっていますが･･････。
もっとこう、せっかくプログラムを使うのだから、内部的に処理できないものなのかな？（画面表示の更新をFalseにするという意味ではなく）

n行おきに改ページさせる

選択範囲内でn行おきに改ページを挿入するマクロです。
例えば、1000行に対して5行ずつ改ページを入れたいときに、200回も手動で改ページなんて入れてられません。
なので、マクロで楽しちゃいましょう。

改ページを設定したい矩形範囲を選択し、

n値を指定します。（仮に2を指定）

2行おきに改ページが挿入されました。

範囲選択する手間はありますが、例えば、同じシートの中で

• 1～50行目までは2行おきに改ページする
• 50～100行目は5行おきに改ページする
• 100行目以降は改ページを指定しない（用紙のサイズに合わせる）

のように、お好みで設定することができます。

HPageBreaks.Addメソッドを使用した簡単なプログラムです。
※一つのシートに1026を超える改ページは追加できません。

Sub n行おきに改ページを入れる()
    '選択範囲の行数がnで割り切れない場合は下端に改ページは入りません
    Dim n As Variant
    Dim y As Long
    Dim ye As Long
    
    n = Application.InputBox(Prompt:="選択範囲内でn行おきに改ページを入れます", Type:=1)
        If TypeName(n) = "Boolean" Or n < 1 Then
            Exit Sub
        End If
    
    y = Selection.Row   '選択範囲の最初の行
    ye = Selection.Rows(Selection.Rows.Count).Row   '選択範囲の最終行
    
    For i = y To ye + 1 Step n
        If i > 1 Then   '1行目以前に改ページを入れることはできない
            ActiveSheet.HPageBreaks.Add (Cells(i, 1))
        End If
    Next i
    
End Sub

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

追記：改ページをすべて解除するには？

ページレイアウトタブ　→　改ページ　→　すべての改ページを解除

で、行うことができます。

複数選択したシートのシート名を取得

選択されているシートのコレクションを返すことのできる、

ActiveWindow.SelectedSheets

というプロパティがあることを初めて知ったので、備忘のために書いておきます。

ActiveSheet

と異なるのは、ActiveSheetは単一のシートが対象になるのに対し、ActiveWindow.SelectedSheetsは複数のシートを対象とすることができます。

複数のセルを選択して、Selectionで取得するようなイメージです。

実験として、選択中のシートのシート名をクリップボードに取得してみましょう。 

「Ctrl」キーを押しながら、Sheet1、Sheet3、Sheet5を選択状態にして、マクロを実行。

こんな感じで、選択したシートのシート名を取得することができました。

For Each ～Nextを使って、シートのコレクションを順次処理するプログラムです。 

Sub 複数選択したシートのシート名をクリップボードに取得()
    '選択したシートは左側から順次ループ処理されます
    Dim V As String
    Dim mySheet As Object
    Dim myLib As Object
    Set myLib = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")  '参照設定なしでDataObjectのインスタンスを生成する

    For Each mySheet In ActiveWindow.SelectedSheets '選択したシートに対してループ処理を行う
        V = V & mySheet.Name & vbCrLf
    Next mySheet
    
    V = Left(V, Len(V) - 2) '最後の改行区切りを取り除く（CrLfは2文字）

    myLib.SetText V  '変数の値をDataObjectに格納する
    myLib.PutInClipboard 'DataObjectのデータをクリップボードに格納する

End Sub

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

検索に一致したセルのみを選択する

選択範囲内で、該当する文字が入っているセルのみを選択する簡単なマクロです。
セルを選択させたのち、セルの背景色を変えるまでをマクロにしてみようと思ったんですが、ふと思い直し、選択するのみにとどめてみました。

ためしに、選択範囲内で3の入っているセルのみを選択させます。

選択されていれば、あとは背景色を変えようが

文字色を変えようが

文字をクリアしようが･･････、自由。

使い方を、使用者のセンスに任せるスタンス。小説でいうと、読者の皆様の想像にお任せするのと同じ（←ぇ）

特殊文字も簡単に検索できるように、

[

#

?

は、ワイルドカードとして使用できないようにしましたが、

*

は、ワイルドカードとして使用できるように残しときました。

Sub 検索に一致したセルのみを選択する()
    '選択範囲内で指定文字を使って検索を行い、検索に一致したセルのみを再選択します
    'ワイルドカードを使って部分一致検索にすることもできます
    'InputBoxが空白なら、空白セルのみを選択します
    '*　を検索する場合はこの文字を[]で囲みます。
    Dim myRange As Range
    Dim myUni As Range
    Dim sw As String
    
    sw = Application.InputBox(Prompt:="検索する文字を指定して下さい。" & vbCrLf & "（ワイルドカードは * のみ使用できます）", Type:=2)
        If sw = "False" Then
            Exit Sub
        End If

    sw = Replace(sw, "[", "[[]")
    sw = Replace(sw, "［", "[［]")
    sw = Replace(sw, "＃", "[＃]")
    sw = Replace(sw, "#", "[#]")
    sw = Replace(sw, "?", "[?]")
    sw = Replace(sw, "？", "[？]")

    For Each myRange In Selection.SpecialCells(xlCellTypeVisible)   '可視セルのみに処理を行う
        If CStr(myRange.Value) Like sw And myRange.Address = myRange.MergeArea(1).Address Then
            If myUni Is Nothing Then
                Set myUni = myRange    '検索に一致した一番最初のセル
            Else
                Set myUni = Union(myUni, myRange)    '検索に一致した二番目以降のセル
            End If
        End If
    Next myRange
    
    If Not myUni Is Nothing Then
        myUni.Select    '検索に一致したセルをまとめて選択する
    End If

End Sub

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