マクロメニュー

Private Sub Workbook_addinInstall()
    '新たにメニューバーを追加する
    Set Menu = Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup)
    'メニューバーの名前
    Menu.Caption = "○ミニマクロ"
   
        'サブメニュー
        Set SubMenu2 = Menu.Controls.Add
        SubMenu2.Caption = "複数ブックを1ブック"
        SubMenu2.OnAction = "確認_複数ブックを1ブックに"

        'サブメニュー
        Set SubMenu3 = Menu.Controls.Add
        SubMenu3.Caption = "複数シートを1シート"
        SubMenu3.OnAction = "確認_複数シートを1シート"
       
        'サブメニュー
        Set SubMenu4 = Menu.Controls.Add
        SubMenu4.Caption = "[●]空白埋め"
        SubMenu4.OnAction = "空白埋め"

        'サブメニュー
        Set SubMenu5 = Menu.Controls.Add
        SubMenu5.Caption = "[？]データ比較"
        SubMenu5.OnAction = "確認_複数列の比較"

        'サブメニュー
        Set SubMenu6 = Menu.Controls.Add
        SubMenu6.Caption = "[→←]結合"
        SubMenu6.OnAction = "文字列を結合する"

        'サブメニュー
        Set SubMenu7 = Menu.Controls.Add
        SubMenu7.Caption = "[↓×]指定列削除"
        SubMenu7.OnAction = "指定列削除"

        'サブメニュー
        Set SubMenu8 = Menu.Controls.Add
        SubMenu8.Caption = "[→×]指定行削除"
        SubMenu8.OnAction = "指定行削除す"
       
        'サブメニュー
        Set SubMenu9 = Menu.Controls.Add
        SubMenu9.Caption = "[↓○]指定列挿入"
        SubMenu9.OnAction = "指定列挿入"

        'サブメニュー
        Set SubMenu10 = Menu.Controls.Add
        SubMenu10.Caption = "[→○]指定行挿入"
        SubMenu10.OnAction = "指定行挿入"

        'サブメニュー
        Set SubMenu11 = Menu.Controls.Add
        SubMenu11.Caption = "[▽]オートフィルタ・分割解除"
        SubMenu11.OnAction = "オートフィルタ等解除"

        'サブメニュー
        Set SubMenu12 = Menu.Controls.Add
        SubMenu12.Caption = "[＄]リンク解除"
        SubMenu12.OnAction = "ハイパーリンク削除"

        'サブメニュー
        Set SubMenu13 = Menu.Controls.Add
        SubMenu13.Caption = "[全]指定列全角化"
        SubMenu13.OnAction = "指定列を全角に"
       
        'サブメニュー
        Set SubMenu14 = Menu.Controls.Add
        SubMenu14.Caption = "[名]名前の定義削除"
        SubMenu14.OnAction = "DeleteDefinedNames"
End Sub

Private Sub Workbook_AddinUninstall()
        'メニューバーを削除
        Application.CommandBars("Worksheet Menu Bar").Controls("○ミニマクロ").Delete
End Sub

名前の定義削除

Public Declare Function SetTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Public Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Sub DeleteDefinedNames()
Dim beforeReferenceStyle As Variant
beforeReferenceStyle = Application.ReferenceStyle
Dim timerID As Long
timerID = SetTimer(0, 0, 100, AddressOfTimerProc)
    If beforeReferenceStyle = xlR1C1 Then
            Application.ReferenceStyle = xlA1
    Else
            Application.ReferenceStyle = xlR1C1
    End If
    Dim n As Name
        For Each n In ActiveWorkbook.Names
            If Not n.Name Like "*!Print_Area" And _
                Not n.Name Like "*!Print_Titles" Then
                n.Delete
                End If
        Next
    Application.ReferenceStyle = beforeReferenceStyle
    KillTimer 0, timerID
End Sub
Private Function getRandomString(min As Long, max As Long) As String
Dim s As String
Dim i As Long
max = Int(max * Rnd)
    For i = 0 To min + max
        Randomize
        s = s & Chr(65 + Int(26 * Rnd))
    Next
   
    getRandomString = s
   
End Function

End Function

複数ブック系

Dim Rst As VbMsgBoxResult
Sub 確認_複数ブックを1ブックに()
'########################
'#  複数のブックを1つのブックにまとめます
'#
'########################
Rst = MsgBox("このブックと同じフォルダにあるファイルをシートとして追加します。" & vbCrLf & _
"同盟のシートを上書きする場合は「はい」・追加する場合は「いいえ」を押してください。実行しますか？", _
vbYesNoCancel + vbQuestion + vbDefaultButton3, _
"複数ブックを1ブックにまとめる")
        If Rst = vbCancel Then
            Exit Sub
        Else
            複数ブックを1ブックに
        End If
End Sub
Sub 複数ブックを1ブックに()
'########################
'#  複数のブックを1つのブックにまとめます
'#
'########################
Dim mb As Workbook
Dim wb As Workbook
Dim ws As Worksheet
Dim sws As Worksheet
Dim myfdr As String
Dim fname As String
Dim n As Integer
Dim Pwd As String
Pwd = InputBox("全ファイルに共通のパスワードを設定している場合、" & vbCrLf & _
"【パスワード】を入力してください" & vbCrLf & _
"パスワードなし、異なるパスワードの場合は空欄のままOKを押してください")
    Application.ScreenUpdating = False
        Set mb = ActiveWorkbook '###このコピー先ブックをmbとする
        myfdr = ActiveWorkbook.Path
        fname = Dir(myfdr & "\*.xls*") 'フォルダ内のexcelブックを検索
       
        i = 1
   
    Do Until fname = Empty    'すべて検索
        If fname <> mb.Name Then    'ブック名がこのブックの名前でなければ
            Set wb = Workbooks.Open(Filename:=myfdr & "\" & fname, UpdateLinks:=0, Password:=Pwd)
            'そのブックを開きwbとする
           
            On Error Resume Next
                For Each ws In wb.Worksheets      'コピー元ブックのシートws全部
                    Set cws = mb.Worksheets(ws.Name) 'コピー先ブックmbのシートン名がコピー元wsと同じものをcwsにする
                        If Not cws Is Nothing Then   'コピー元とコピー先に同じシート名があったら
                            If Rst = vbYes Then 'シートの上書きOKなら
                                Application.DisplayAlerts = False
                                mb.Worksheets(ws.Name).Delete     'コピー先のシートを削除
                                Application.DisplayAlerts = True
                            Else
                                wb.Worksheets(ws.Name) = wb.Worksheets(ws.Name) & i 'コピー元ブックのシートwsの名前に数字をつける
                               
                                '名前の定義は消してしまう
                                With wb.Worksheets(ws.Name)
                                DeleteDefinedNames
                                End With
                               
                                i = i + 1
                            End If
                        End If
                    ws.Copy after:=mb.Sheets(mb.Sheets.Count)   'コピー元wsをコピー先mbにコピー、ブックの末尾に置く
                        Next
                        
                         On Error GoTo 0
                         wb.Close savechanges:=False    'コピー元wbを閉じる
                         n = n + 1
        End If
       
        fname = Dir 'フォルダ内の次のExcelブックを検索
        Loop
        Application.ScreenUpdating = True
       
        ActiveWorkbook.Save
        MsgBox n & "件のブックをコピーしました"
End Sub

       
           
                               
                               
                   

ミニマクロ

Sub 空白埋め()
'########################
'#  範囲を指定して空白を埋めます
'########################
Dim SCol As Variant, RCol As Variant, SRow As Variant
        SCol = InputBox("埋める【開始列】を" & vbCrLf & _
        "【数字】で入力")
  
        ECol = InputBox("埋める【終了列】を" & vbCrLf & _
        "【数字】で入力")
  
        SRow = InputBox("何行目から始めますか？" & vbCrLf & _
        "【開始行】【数字】で入力")
  
        'キャンセルを押されたらマクロを停止する
        If SCol = "" Or ECol = "" Or SRow = "" Then Exit Sub
  
        'エラーチェックをしたので数字にする
        SCol = Val(SCol)
        ECol = Val(ECol)
        SRow = Val(SRow)
 
 Dim Sh As Worksheet
 Dim rngTARGET As Range
 Dim BUF As Variant
 Dim r As Long
 Dim c As Long
 Dim MaxRow As Long
 Dim cRM As Range

        Set Sh = ActiveSheet
       
        '指定した列の中で一番行数が多い列の行数を変数に入れる【MaxRow】
        For Each cRM In Range(Cells(SRow, SCol), Cells(SRow, ECol))  '最初の行の開始終了列
                If Sh.Cells(Rows.Count, cRM.Column).End(xlUp).Row > MaxRow Then
                        MaxRow = Sh.Cells(Rows.Count, cRM.Column).End(xlUp).Row
                End If
        Next

        '２行目以下の使用済みセル範囲の値を配列化【rngTARGET】
        Set rngTARGET = Sh.Range(Cells(SRow, SCol), Cells(MaxRow, ECol))
       
        BUF = rngTARGET.Value
       
        '空白を埋める
        For r = 1 To UBound(BUF)  '行方向
                For c = 1 To UBound(BUF, 2)
                        If IsEmpty(BUF(r, c)) Then
                                BUF(r, c) = BUF(r - 1, c)
                        End If
                Next c
        Next r
       
        'データ書き出し
        rngTARGET.Value = BUF
       
        '後始末
        Erase BUF
        Set rngTARGET = Nothing
        Set Sh = Nothing

 MsgBox "空白を埋めました"
 End Sub


 Sub 確認_複数シートを1シート()

'########################
'#  複数のシートを１つのシートにまとめます。
'#  見出しは最初のシートから作られます。
'#  １行目に見出し行がある同じ形式のシートを１枚にまとめたい時に使います。
'########################
選択 = MsgBox("見出しが同じ複数のシートを１つのシートにまとめます。" & vbCrLf & _
        "見出しは最初のシートから作られます。(見出しの複数行指定は不可)" & vbCrLf & _
        "実行しますか？", vbYesNo + vbExclamation, _
        "複数シートを１シートにまとめる")
       
        If 選択 = vbYes Then               '[はい]なら
                複数シートを1シート
        Else                                            '[いいえ]なら
                Exit Sub
        End If
End Sub
 Sub 複数シートを1シート()

'########################
'#  複数のシートを１つのシートにまとめます。
'#  見出しは最初のシートから作られます。
'#  １行目に見出し行がある同じ形式のシートを１枚にまとめたい時に使います。
'########################
Dim SCol As Variant, SRow As Variant
    SRow = InputBox("見出しは【何行目】にありますか？" & vbCrLf & _
        "【数字】で入力してください")
       
    SCol = InputBox("データは【何列目】から始まりますか？" & vbCrLf & _
        "【数字】で入力してください")
       
        'キャンセルが押されたらマクロを終了する
        If SRow = "" Or SCol = "" Then Exit Sub
       
    'エラーチェックをしたので数字にする
    SRow = Val(SRow)
    SCol = Val(SCol)
       
Dim i As Integer
Dim MaxRow As Long, MaxRow2 As Long, ECol As Long
Dim cRM As Range
Dim PSh As Worksheet
Dim CSh As Worksheet
        Application.ScreenUpdating = False
    '-----全データシートの有無をチェックします
    Call sh_check
    Set PSh = Worksheets("全データ")
    Set CSh = Worksheets(2)
    '------見出し行をたどって列数を決める
    ECol = CSh.Cells(SRow, Columns.Count).End(xlToLeft).Column
   
        '------列見出しをコピー
        CSh.Range(CSh.Cells(SRow, SCol), CSh.Cells(SRow, ECol)).Copy PSh.Range(PSh.Cells(1, 1), PSh.Cells(1, ECol))
       
            For i = 2 To Worksheets.Count
                With Worksheets(i)
                    Set CSh = Worksheets(i)
                   
                    '指定した列の中で一番行数が多い列の行数を変数に入れる
                    For Each cRM In Range(.Cells(SRow, SCol), .Cells(SRow, ECol))
                        If .Cells(Rows.Count, cRM.Column).End(xlUp).Row > MaxRow Then
                            MaxRow = .Cells(Rows.Count, cRM.Column).End(xlUp).Row
                        End If
                    Next
                   
                    '-----シートのデータが2行以上の場合にコピー
                    If MaxRow >= 2 Then
                   
                        '指定した列の中で一番行数が多い列の行数を変数に入れる★貼付側
                        For Each cRM In Range(PSh.Cells(1, 1), PSh.Cells(1, ECol))
                            If PSh.Cells(Rows.Count, cRM.Column).End(xlUp).Row > MaxRow2 Then
                                MaxRow2 = PSh.Cells(Rows.Count, cRM.Column).End(xlUp).Row + 1
                            End If
                        Next
                       
                        .Activate
                        .Range(Cells(SRow + 1, SCol), Cells(MaxRow, ECol)).Copy PSh.Cells(MaxRow2, 1)
                    End If
                End With
               
            Next i
           
            PSh.Activate
            Range("A1").Select
            Application.ScreenUpdating = True
           
        MsgBox "シートをまとめました"
       
End Sub
Sub sh_check()
'########################
'#  シートの有無を判定
'########################
Dim newSh As String
Dim Sh As Worksheet, myFlag As Boolean
        newSh = "全データ"
        myFlag = False
       
            For Each Sh In ActiveWorkbook.Worksheets
                If Sh.Name = newSh Then
                    myFlag = True
                    '-----全データシートのデータをクリアし、先頭へ移動します
                    Worksheets(newSh).Cells.ClearContents
                    Worksheets(newSh).Move before:=Worksheets(1)
                End If
            Exit For
            Next Sh
            '-----全データシートを先頭へ追加します
            If myFlag = False Then
                ActiveWorkbook.Worksheets.Add(before:=Worksheets(1)).Name = newSh
            End If
End Sub
Sub 確認_複数列の比較()
'########################
'#  4列までのデータを比較します。
'#  同じデータがあればOK、なければNGを出します。
'#  動きが重いので行数が多いと待たされます
'########################
選択 = MsgBox("上下に並んだ2つのデータを比較します。" & vbCrLf & _
"【！】必ずA列から開始します" & vbCrLf & _
"【！】双方のデータ間は2行以上開けてください" & vbCrLf & _
"比較できるのは4列までです" & vbCrLf & _
"実行しますか？", vbYesNo + vbExclamation, _
"複数列の比較")
        If 選択 = vbYes Then
            複数列の比較
        Else
            Exit Sub
        End If
End Sub
Sub 複数列の比較()
'########################
'#  4列までのデータを比較します。
'#  同じデータがあればOK、なければNGを出します。
'#  動きが重いので行数が多いと待たされます
'########################
Dim i As Integer, ii As Integer, res1 As Variant, res2 As Variant
res1 = InputBox("データ1の開始行番号を入力してください")
res2 = InputBox("データ2の開始行を入力してください")
       'キャンセルを押されたらマクロを停止する
        If res1 = "" Or res2 = "" Then Exit Sub
   
        'エラーチェックをしたので数字にする
        res1 = Val(res1)
        res2 = Val(res2)
   
        '画面更新を休止する
       ' Application.ScreenUpdating = False
       
            For i = res1 To Range("A" & res1).End(xlDown).Row
                For ii = res2 To Range("A" & res2).End(xlDown).Row
                    If Cells(ii, 1).Value = Cells(i, 1).Value And Cells(ii, 2).Value = _
                       Cells(i, 2).Value And Cells(ii, 3).Value = Cells(i, 3).Value Then
                            If Cells(ii, 4).Value <> Cells(i, 4).Value Then
                                If Cells(i, 6).Value = "" Then
                                    Cells(i, 6).Value = Rows(ii).Row
                                Else
                                    Cells(i, 6).Value = Cells(i, 6).Value & "," & Rows(ii).Row
                                End If
                            Else
                                If Cells(i, 6).Value = "" Then
                                    Cells(i, 6).Value = Rows(ii).Row & "-OK"
                                Else
                                    Cells(i, 6).Value = Cells(i, 6).Value & "," & Rows(ii).Row & "-OK"
                                End If
                            End If
                        End If
                    Next
            Next
        With Cells(res1, 5)
            .FormulaR1C1 = "=if(iserror(find(""OK"",rc[1],1))=false,""OK"",""NG"")"
            .Copy
        End With
       
        Range(Cells(res1, 5), Cells(Range("A" & res1).End(xlDown).Row, 5)).PasteSpecial Paste:=xlPasteFormulas
       
        Application.CutCopyMode = False
       
       ' Application.ScreenUpdating = True
       
    MsgBox "比較が完了しました"
End Sub
                      
 Sub ハイパーリンク削除()

'########################
'#  開いているシートのハイパーリンクを全部削除します。
'#
'#
'########################
選択 = MsgBox("今開いているシートのハイパーリンクを全部削除します。実行しますか？", vbYesNo + vbExclamation, _
"ハイパーリンクの削除")
        If 選択 = vbYes Then
            ActiveSheet.Hyperlinks.Delete
        Else
            Exit Sub
        End If
MsgBox "ハイパーリンクを削除しました"
End Sub
Sub 文字列を結合する()

'########################
'#  複数行に同じ文字列が連続するセルを結合します
'#
'#
'########################
Dim myCol As Integer
Dim SCol As Variant
Dim ECol As Variant
Dim SRow As Variant
Dim myRng As Range
Dim myRow As Long
Dim cRM As Range
Dim MaxRow As Long
        SCol = InputBox("縦方向に同じ文字があれば結合します。【何列目】から開始しますか？数字で列を指定してください")
ECol = InputBox("何列目まで作業しますか？数字で列を指定してください")
SRow = InputBox("何行目から開始しますか？数字で行を指定してください")
    'キャンセルを押されたらマクロを停止する
    If SCol = "" Or ECol = "" Or SRow = "" Then Exit Sub
   
    'エラーチェックをしたので数字にする
    SCol = Val(SCol)
    ECol = Val(ECol)
    SRow = Val(SRow)
   
    '指定した列の中で一番行数が多い列の行数を変数に入れる
    For Each cRM In Range(Cells(SRow, SCol), Cells(SRow, ECol))
        If Cells(Rows.Count, cRM.Column).End(xlUp).Row > MaxRow Then
            MaxRow = Cells(Rows.Count, cRM.Column).End(xlUp).Row
        End If
    Next
   
    '画面更新を休止する
    Application.ScreenUpdating = False
   
    '列[myCol]==============================
   
        myCol = SCol  'SCol 列から
   
        Do While myCol <= ECol     'ECol列まで、以下を繰り返します
   
    '行[myRow]==============================
   
        '指定行から各列を場所指定
        Set myRng = Cells(SRow, myCol)
       
            '指定行、指定列の中で以下作業をする
            With Cells(myRow, myCol)
                '今いる行の上の一つ下と今の行の値が同じなら
                If .Value = .Offset(1, 0).Value Then
                    '下の行と今の行を範囲指定する
                    Set myRng = Union(myRng, .Offset(1, 0))
                '下の行が違う値なら
                Else
                    '指定範囲の結合を実行する
                    Application.DisplayAlerts = False
                    myRng.Merge
                    Application.DisplayAlerts = True
                   
                    '一つ下に進む
                    Set myRng = .Offset(1, 0)
                End If
            End With
        Next
    '列＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
        '次の列に進む
        myCol = myCol + 1
        Loop
        '画面更新を再開する
        Application.ScreenUpdating = True
    MsgBox "結合しました"
End Sub
   
Sub オートフィルタ等解除()

'########################
'#  ウィンドウ分割とオートフィルタを解除
'#　解除したいしオートを開いてから実行する
'#
'########################
Dim xlApp As Excel.Application
選択 = MsgBox("今開いているシートのウィンドウ分割とオートフィルタを解除します。実行しますか？", vbYesNo + vbExclamation, _
"ウィンドウ分割とオートフィルタを解除")
    If 選択 = vbYes Then
        '画面更新を休止する
        Application.ScreenUpdating = False
       
        Cells.Select
        Selection.EntireColumn.Hidden = False
        ウィンドウ分割解除
        オートフィルタ解除
    Else
        Exit Sub        '実行中止
    End If
   
        '画面更新を再開する
        Application.ScreenUpdating = True
    MsgBox "ウィンドウ分割とオートフィルタを解除しました"
   
End Sub
Sub オートフィルタ解除()
    If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
End Sub
Sub ウィンドウ分割解除()
    ActiveWindow.FreezePanes = False
   
End Sub
   
Sub 指定行削除す()

'########################
'#  特定の文字列がある行を削除したい場合に使用
'#　作業したいシートを開いてから実行する
'#
'########################
res1 = InputBox("指定したキーワードがある行を削除します。" & vbCrLf & _
    "【キーワード】を入力してください「＊」使用可。")
SCol = InputBox("キーワードがある【列】は何列目ですか？" & vbCrLf & _
"【数字】で指定してください")
    'キャンセルを押されたらマクロを停止する
    If SCol = "" Then Exit Sub
   
    'エラーチェックをしたので数字にする
    SCol = Val(SCol)
   
    'データ最終行
    MaxRow = Cells(Rows.Count, SCol).End(xlUp).Row
    Application.ScreenUpdating = False
    For i = MaxRow To 1 Step -1
        If Cells(i, SCol) Like res1 Then
            Range(i & ":" & i).Delete
        End If
       
        Next i
        Application.ScreenUpdating = True
       
        MsgBox "行を削除しました"
       
End Sub
Sub 指定行挿入()

'########################
'#  特定の文字列の上に行を挿入したい場合に使用
'#　作業したいシートを開いてから実行する
'#
'########################

Dim res1 As String
Dim MaxRow As Long
Dim i As Long
Dim SCol As Variant
res1 = InputBox("指定したキーワードがある行の上に行を挿入します。" & vbCrLf & _
    "【キーワード】を入力してください「＊」使用可。")
SCol = InputBox("キーワードがある【列】は何列目ですか？" & vbCrLf & _
"【数字】で指定してください")

    'キャンセルを押されたらマクロを停止する
    If SCol = "" Then Exit Sub
   
    'エラーチェックをしたので数字にする
    SCol = Val(SCol)
   
    'データ最終行
    MaxRow = Cells(Rows.Count, SCol).End(xlUp).Row
    Application.ScreenUpdating = False
    For i = MaxRow To 1 Step -1
        If Cells(i, SCol) Like res1 Then
            Range(i & ":" & i).Insert
        End If
       
        Next i
        Application.ScreenUpdating = True
       
        MsgBox "行を挿入しました"
       
End Sub
Sub 指定列削除()
'########################
'#  特定の見出しの前に列を挿入したい場合に使用
'#　作業したいシートを開いてから実行する
'#　画面更新をoffにすると削除できない・・
'########################
Dim res1 As String
Dim SRow As Variant
Dim MaxCol As Long
Dim i As Long
res1 = InputBox("指定したキーワードがある列を削除します。" & vbCrLf & _
"【キーワード】を入力してください。「＊」使用可")
SRow = InputBox("キーワードがある【行】は何行目ですか？" & vbCrLf & _
"【数字】で指定してください")
    'キャンセルを押されたらマクロを停止する
    If SRow = "" Then Exit Sub
   
    'エラーチェックをしたので数字にする
    SRow = Val(SRow)
   
    'データ最終列
    MaxCol = Cells(SRow, Columns.Count).End(xlToLeft).Column
   
    For i = MaxCol To 1 Step -1
        If Cells(SRow, i) Like res1 Then
            Columns(i).Delete
        End If
    Next i
MsgBox "列を削除しました"
End Sub

Sub 指定列挿入()
'########################
'#  特定の見出しの前に列を挿入したい場合に使用
'#　作業したいシートを開いてから実行する
'#
'########################
Dim res1 As String
Dim SRow As Variant
Dim MaxCol As Long
Dim i As Long
res1 = InputBox("指定したキーワードがある列の前に列を挿入します。" & vbCrLf & _
"【キーワード】を入力してください。「＊」使用可")
SRow = InputBox("キーワードがある【行】は何行目ですか？" & vbCrLf & _
"【数字】で指定してください")
    'キャンセルを押されたらマクロを停止する
    If SRow = "" Then Exit Sub
   
    'エラーチェックをしたので数字にする
    SRow = Val(SRow)
   
    'データ最終列
    MaxCol = Cells(SRow, Columns.Count).End(xlToLeft).Column
   
    Application.ScreenUpdating = False
   
    For i = MaxCol To 1 Step -1
        If Cells(SRow, i) Like res1 Then
            Columns(i).Insert
        End If
    Next i
   
    Application.ScreenUpdating = False
MsgBox "列を挿入しました"
End Sub
Sub 指定列を全角に()
'########################
'#  半角を全角に変換します
'#
'########################
Dim x As Long
Dim y1 As Long
Dim y2 As Long
Dim aa As valiant
Dim bb As Range
y1 = InputBox("全角にしたい開始列を数字で入力してください")
y2 = InputBox("全角にしたい終了列を数字で入力してください") + 1
x = InputBox("全角にしたい行のはじめを数字で入力してください")
        Do While y1 < y2
            Columns(y1).Select         '列を選択します
            Set bb = Intersect(Selection, ActiveSheet.UsedRange)   '選択されたシートが指定の基準（コード入り）と一致する場合
            aa = bb.Value
           
                For x = x To UBound(aa, y1)   '1列1行～データが入っている最後のaa行1列まで
                    aa(x, y1) = StrConv(aa(x, y1), vbWide) '文字列を数字にします
                Next x
               
            bb.Value = aa
           
            Set bb = Nothing
           
            y1 = y1 + 1
        Loop
End Sub

End Sub

アンインストーラ２

on error resume next
dim installPath
dim addInName
dim addInFileName
dim objExcel
dim objAddin
'アドイン情報を設定
addInName="○ミニマクロ"
addInFileName="MacroTools.xlam"
if Msgbox(addInName & "マクロをアンインストールしますか？", vbyesno + vbQuestion)=vbno then
 wscript.quit
end if
'Excelインスタンス化
set objExcel=createobject("Excel.application")
objExcel.workbooks.add
'アドイン登録解除
for i = 1 to objExcel.addins.count
 set objAddin = objExcel.addins.item(i)
 if objAddin.Name = addInFileName then
  objAddin.Installed = false
 end if
 next
 objExcel.Quit
set objAddin = nothing
set objExcel = nothing
set objWshShell = createobject("WScript.Shell")
set objFileSys = createobject("Scripting.FileSystemObject")
'インストール先パスの作成
installPath = objWshShell.SpecialFolders("Appdata") & "\Microsoft\Addins\" & addInFileName
'ファイル削除
if objFileSys.FileExists(installPath) = true then
 objFileSys.DeleteFile installPath , true
else
 msgbox "マクロファイルが存在しません", vbExclamation
end if
set objWshShell = nothing
set objFileSys = nothing
if Err.Number = 0 then
 msgbox "マクロのアンインストールが終了しました", vbInformation
else
 msgbox "エラーが発生しました。実行環境を確認してください"
end if

インストーラ

on error resume next
dim installPath
dim addInName
dim addInFileName
dim objExcel
dim objAddin
'アドイン情報を設定
addInName="○ミニマクロ"
addInFileName="MacroTools.xlam"
if Msgbox(addInName & "マクロをインストールしますか？", vbyesno + vbQuestion)=vbno then
 wscript.quit
end if
set objWshShell = createobject("WScript.Shell")
set objFileSys = createobject("Scripting.FileSystemObject")
'インストール先パスの作成
installPath = objWshShell.SpecialFolders("Appdata") & "\Microsoft\Addins\" & addInFileName
C:\Users\Dolphin\AppData\Local\Packages\Microsoft.Office.Desktop_8wekyb3d8bbwe\LocalCache\Roaming\Microsoft\AddIns
'ファイルコピー（上書き）
objFileSys.CopyFile addInFileName, installPath, true
set objWshShell = nothing
set objFileSys = nothing

'Excelインスタンス化
set objExcel=createobject("Excel.application")
objExcel.workbooks.add
'マクロ登録
set objAddin = objExcel.AddIns.Add(installPath, true)
objAddin.Installed = true
'Excel終了
objExcel.Quit
set objAddin = nothing
set objExcel = nothing
if Err.Number = 0 then
 msgbox "マクロのインストールが終了しました", vbInformation
else
 msgbox "エラーが発生しました。実行環境を確認してください"
end if