ミニマクロ

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