Excel VBA セル操作

Option Explicit
Sub 選択範囲を取得し､A1形式で表示()
    Dim 選択範囲 As Range
    If TypeName(Selection) = "Range" Then
        Set 選択範囲 = Selection
        MsgBox 選択範囲.Address
    Else
        MsgBox "セルが選択されていません"
    End If
    Set 選択範囲 = Nothing 'オブジェクトの解放
End Sub

Sub セルのデータチェック()
    Dim チェック対象セル範囲 As Range
    Dim 行 As Integer
    Dim 移動行 As Integer
    Dim 列 As Integer
    Dim メッセージ As String
    Dim タイトル As String
    Dim 返答 As Integer
    
    '範囲を表す変数にアクティブセル領域への参照を代入します。
    Range("A1").Select
    Set チェック対象セル範囲 = ActiveCell.CurrentRegion
    ActiveCell.CurrentRegion.Interior.ColorIndex = 6
        メッセージ = "データ部分の行数は、" & チェック対象セル範囲.Rows.Count - 1 & "です。"
        タイトル = "データ行数確認"
        返答 = MsgBox(メッセージ, vbInformation + vbYesNo, タイトル)
        'vbInformation は、情報メッセージ アイコン。 
        'vbYesNo は、[はい] と [いいえ] のボタンを表示。
        If 返答 = 7 Then Exit Sub ' 6*Yes, 7:No
        
    For 列 = 1 To 3
        For 行 = 2 To チェック対象セル範囲.Rows.Count - 1
        
        Select Case 列
        
        Case 1
        '「在庫数」列の各セルを検査します。
            If Not (IsNumeric(Range("A2").Cells(行, 列).Value)) _
            Or Trim(Range("A2").Cells(行, 列).Value) = "" Then

                MsgBox "「在庫数」列に数値以外のデータが見つかりました。"
                If 行 <= 10 Then 移動行 = 1 Else 移動行 = 行 - 10
                ActiveWindow.ScrollRow = 移動行
                Range("A2").Cells(行, 列).Activate
                Exit Sub
            End If
            
        Case 2
            '「注文中」列の各セルを検査します。
            If Not (Range("A2").Cells(行, 列).Value = "済み" _
                 Or Range("A2").Cells(行, 列).Value = "未") Then
                MsgBox "「注文中」列に指定(済みor未)以外のデータが見つかりました。"
                If 行 <= 10 Then 移動行 = 1 Else 移動行 = 行 - 10
                ActiveWindow.ScrollRow = 移動行
                Range("A2").Cells(行, 列).Activate
                Exit Sub
            End If
            
        Case 3
            '「品目番号」列の各セルを検査します。
                If Not (IsNumeric(Left(Range("A2").Cells(行, 列).Value, 5))) _
                Or Len(Range("A2").Cells(行, 列).Value) <> 10 Then
                MsgBox "「品目番号」が10桁でないか、または最初の5文字に、数値以外が有ります。"
                If 行 <= 10 Then 移動行 = 1 Else 移動行 = 行 - 10
                ActiveWindow.ScrollRow = 移動行
                Range("A2").Cells(行, 列).Activate
                Exit Sub
            End If
        End Select
        Next 行
    Next 列
End Sub

Option Explicit
Sub ハイホンを含むセルに色を付ける()
    Dim セル As Range
    
    For Each セル In [A1:C5]
        If セル.Value Like "*-*" Then
           セル.Interior.ColorIndex = 3 '赤色
        End If
    Next
End Sub

Option Explicit
Sub フォント置換と統一()
    Dim セル As Range
    
    For Each セル In [A1:C5]
        If セル.Font.Name Like "Arial*" Then
           セル.Font.Name = "ＭＳ ゴシック"
        End If
        If セル.Font.Size <> "10" Then
           セル.Font.Size = "10"
        End If
    Next
End Sub

Option Explicit
Sub データの置換()
    Dim 検索セル As Range
    Dim 開始セルアドレス As String
    
    With Range("A1:C5")
        Set 検索セル = .Find(2, LookIn:=xlValues)
        If Not 検索セル Is Nothing Then
            開始セルアドレス = 検索セル.Address
            Do
                Set 検索セル = .FindNext(検索セル)
                検索セル.Value = 5
                検索セル.Interior.ColorIndex = 3 '赤色
            Loop While Not 検索セル Is Nothing And 検索セル.Address <> 開始セルアドレス

            '　検索は指定された範囲の最後に達すると、範囲の最初に戻って検索を繰り返します。
            '同じ範囲を繰り返して検索しないようにするには、
            '最初に検索内容が見つかったセルの位置を保存しておき、
            '次のセルが見つかるたびに、
            'そのセルの位置と保存しておいたセルの位置を比較するようにします。
        End If
    End With
    Range("A1").Activate
End Sub

Option Explicit
Sub セルの関数の置換()
    Columns("A").Replace What:="SIN", Replacement:="COS", _
        SearchOrder:=xlByColumns, MatchCase:=True:
    Range("A1").Activate
End Sub

Option Explicit
Sub 文字の置換()
Dim セル As Range

    For Each セル In [A1:C5]
        If セル.Value Like "*-*" Then
            セル.Replace What:="-", Replacement:="|", _
            SearchOrder:=xlByColumns, MatchCase:=True
            セル.Interior.ColorIndex = 3 '赤色
        End If
    Next
    Range("A1").Activate
End Sub

   文字列 = データシート.Range("A1").Cells(対象行, 対象列).Value 'セル内改行を含む文字列
   改行までの文字列 = Left(文字列, InStr(文字列, vbLf) - 1)

Option Explicit
Option Base 1

   Dim 検索文字列 As String
   Dim 置換文字列 As String
   Dim シート As Worksheet
   Dim ブック名配列(1000, 10) As String
   Dim ブック数 As Integer
   Dim 置換シート数 As Integer
   Dim フォルダパス As String
   
Sub 対象フォルダの全てのExcelで置換()

   Dim Excelバージョン As Integer
   Dim フォルダ As Object
   Dim ファイル As Object
   Dim ファイルシステムオブジェクト As Object
   Dim ファイル名 As String
   
   'Excel のバージョンを取得：バージョンによって異なるコードを書くため
   Excelバージョン = Application.Version
   
   '「検索」「置換」文字列を取得
   ThisWorkbook.Worksheets("スタート").Activate
   検索文字列 = Range("C11").Value
   置換文字列 = Range("C12").Value
   
   If 検索文字列 = "" Then
      MsgBox "検索文字列が指定されていません。終了します。"
      Exit Sub
   End If
   
   Call ファイルを開くダイアログを使って対象フォルダを取得

   'ファイルシステム・オブジェクトを使って、フォルダ、ファイルを操作する
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   Set フォルダ = ファイルシステムオブジェクト.GetFolder(フォルダパス)
   
   '★Excelの存在するフォルダの全てのファイルを対象
   ブック数 = 0
   For Each ファイル In フォルダ.Files
   
      ファイル名 = ファイル.Name
      'このVBAのブック自身は、置換の対象外とする
      If ファイル名 <> ThisWorkbook.Name Then
      
         'ファイルの拡張子を調べて、Excelブックのみを、置換対象とする
         If LCase(Mid(ファイル名, InStrRev(ファイル名, ".") + 1, 3)) = "xls" Then
         
            'ファイルが、置換対象の Excel ブックだったら
            ブック数 = ブック数 + 1
            
            'Excelブックを開く
            Workbooks.Open Filename:=ファイル名
            
            '開いた、作業対象のブックの、全てのワークシートで、文字列を検索して置換
            置換シート数 = 0
            For Each シート In Workbooks(ファイル名).Worksheets
            
               Call データの入力されているセルを検索して置換
               
            Next シート
               
            '処理結果を、配列に書き込む
            ブック名配列(ブック数, 1) = ブック数
            ブック名配列(ブック数, 2) = ファイル名
            ブック名配列(ブック数, 3) = 置換シート数
               
            If 置換シート数 = 0 Then
               '置換対象の文字列が存在しなかったら
               ActiveWorkbook.Close False 'ブックの変更を保存しないで閉じる。
            Else
               'いずれかのシートで、置換をした場合
               
               'Excel 2007〜の場合
               If Excelバージョン > 11 Then
                  '[互換性チェック] ダイアログで、機能を無効にする
                  '[このブックを保存するときに互換性を確認する] を外す
                  ActiveWorkbook.CheckCompatibility = False
               End If
               ActiveWorkbook.Close True 'ブックの変更を保存して閉じる。
            End If
            
         End If '全てのExcelブック
      End If 'このブック以外
   Next ファイル '全てのファイル

   'オブジェクトを解放する
   Set フォルダ = Nothing
   Set ファイルシステムオブジェクト = Nothing
   
   Call テンプレートをコピーしたシートに結果を出力
   
End Sub


Private Sub テンプレートをコピーしたシートに結果を出力()
   Dim 追加シート名初期 As String
   Dim 追加シート名 As String
   Dim 重複 As Integer
   Dim シート数 As Integer
   
   ThisWorkbook.Worksheets("スタート").Activate
   
    追加シート名初期 = "置換結果"
    追加シート名 = 追加シート名初期

    For 重複 = 1 To 100
    ' 100枚まで追加しても重複しないように追番を設定します。
        For Each シート In Worksheets
            If シート.Name = 追加シート名 Then
                追加シート名 = 追加シート名初期 & "(" & 重複 & ")"
            End If
        Next シート
    Next 重複
    シート数 = Worksheets.Count
    Worksheets("テンプレート").Copy After:=Worksheets(シート数)
    ActiveSheet.Name = 追加シート名

   Range("A2").Resize(ブック数, 10) = ブック名配列
   
End Sub


Private Sub データの入力されているセルを検索して置換()
   Dim 見つかったセル As Range
   
   With シート.UsedRange
   
      'Find ステートメントは、Rangeオブジェクトを返すので、Set で代入
      Set 見つかったセル _
         = .Find(what:=検索文字列 _
            , LookIn:=xlValues _
            , LookAt:=xlPart _
            , MatchByte:=False)
      
      If Not 見つかったセル Is Nothing Then
         '検索対象が存在した場合
         置換シート数 = 置換シート数 + 1
         
         .Replace _
            what:=検索文字列 _
         , Replacement:=置換文字列 _
         , LookAt:=xlPart _
         , SearchOrder:=xlByRows _
         , MatchCase:=False _
         , SearchFormat:=False _
         , ReplaceFormat:=False
         
         'シートに置換対象があったら、最初の7シートまで、シート名を配列に登録
         If 置換シート数 > 0 And 置換シート数 < 8 Then
            ブック名配列(ブック数, 置換シート数 + 3) = シート.Name
         End If
         
      End If
      'セル・オブジェクトを解放する
      Set 見つかったセル = Nothing
   End With 'データの登録されているセル
   
End Sub


Private Sub ファイルを開くダイアログを使って対象フォルダを取得()
   Dim Excelブックのパス As String
      
   'ファイルを開くダイアログの、デフォルトのパスを、このブックのパスを使って指定
   ChDrive ThisWorkbook.Path
   ChDir ThisWorkbook.Path

   '[ファイルを開く]ダイアログボックスで、ファイルを指定して、パスを取得
   Excelブックのパス = Application.GetOpenFilename("Excelブック,*.xls*")
   
   '[ファイルを開く]で「キャンセル」した場合は、処理を終了
   If Excelブックのパス = "False" Then End

   'Excelブックのパスから、後ろのファイル名の部分を削除して、フォルダ・パスを取得
   フォルダパス = Left(Excelブックのパス, InStrRev(Excelブックのパス, "\"))

End Sub

Sub 集計()
    Dim シート数 As Integer
    Dim シート名 As String
    Dim 対象セル範囲 As Range  ' 一覧のセル範囲

    ' 処理を高速化するため、画面描画停止､自動計算停止
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    '生徒数集計という名前のシートを追加してデータをコピーします。
    シート数 = ThisWorkbook.Sheets.Count
    シート名 = "生徒数集計"
    ThisWorkbook.Worksheets("生徒数").Copy After:=Sheets(シート数)
    ActiveSheet.Name = シート名

    ' Withステートメントで、ワークシートの指定を省略
    With Worksheets("生徒数集計")
        ' A1セル起点で表全体を選択して、集計を行なう。
        Range("A1").Select
        Set 対象セル範囲 = ActiveCell.CurrentRegion
        With 対象セル範囲
            ' 集計処理を学年とクラスの2回行なう。
            .Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(4), _
                Replace:=True, PageBreaks:=False, SummaryBelowData:=True
            .Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(4), _
                Replace:=False, PageBreaks:=False, SummaryBelowData:=True
        End With
        .Calculate ' 再計算
    End With


    Dim 検索セル As Range
    Dim 合致セル As String
    Dim 合致行 As Integer

    For i = 1 To 2
    'シートの1列目と2列目を対象に検索
    With Worksheets("生徒数集計").UsedRange.Columns(i)  
        Set 検索セル = .Find("計")       '---検索セルに検索結果を格納
        If Not 検索セル Is Nothing Then    '---条件に当てはまるセルがあれば
           合致セル = 検索セル.Address   '---最初のセルのアドレスを覚える
           Do
               Set 検索セル = .FindNext(検索セル)
                '---今見つけたセルから次のセルを検索
                合致行 = 検索セル.Rows.Row
                Rows(合致行).Select
                If i = 2 Then
                    With Selection.Interior
                        .ColorIndex = 36
                        .Pattern = xlSolid
                    End With
                Else
                    With Selection.Interior
                        .ColorIndex = 34
                        .Pattern = xlSolid
                    End With
                End If
           Loop While Not 検索セル Is Nothing _
           And 検索セル.Address <> 合致セル  '----条件に当てはまる全てを検索
         End If
    End With
    Set 検索セル = Nothing
    Next i
    Range("B2").Select
    
    ' 画面描画再開､自動計算停止解除
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Option Explicit

Sub Flow()
    Call 並び替え
    Call 重複行削除�@
End Sub

Private Sub 並び替え()
    ThisWorkbook.Worksheets("Sheet1").Activate
    Range("A1").Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Sort _
        Key1:=Range("A1"), _
        Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlPinYin
    ThisWorkbook.Worksheets("Sheet1").Range("A1").Select
End Sub

Private Sub 重複行削除�@()
    ThisWorkbook.Worksheets("Sheet1").Activate
    ActiveCell.CurrentRegion.AdvancedFilter _
    Action:=xlFilterCopy, _
    CopyToRange:=Sheets("Sheet2").Range("A1"), _
    unique:=True '重複するレコードを無視
    ThisWorkbook.Worksheets("Sheet2").Activate
    Range("A1").Select
End Sub



Sub 重複行削除�A()
    ThisWorkbook.Worksheets("Sheet1").Activate
    Dim i As Integer
    With Range("A2")
        Do While .Offset(i, 0) <> ""
            If .Offset(i, 0) = .Offset(i - 1, 0) Then
            .Offset(i, 0).EntireRow.Delete
            Else
            i = i + 1
            End If
        Loop
    End With
End Sub

Option Explicit

Sub 重複行を削除()

    Dim 対象ブック As String
    Dim 指定セル As Range
    Dim 名前 As String
    Dim アドレス As String
    Dim シート As String
    
    ' 処理対象シートを選択して、列名とシート名を取得

    On Error GoTo キャンセル
    Set 指定セル = Application.InputBox _
        (prompt:="処理するBookの、シートの対象列の、適当なセルを選択してください" _
        , Title:="処理対象列の指定" _
        , Type:=8)  ' 8は、セル参照 (Range オブジェクト)

    ' 事例では、このマクロは、「DeleteRepetitiousLines.xls」というファイル名。
    ' 指定セルの Range に対して、.Parent で親オブジェクトWorksheets を､
    ' その.Parent で、Workbooks を、取得します。

    対象ブック = 指定セル.Parent.Parent.Name
    If 対象ブック = "DeleteRepetitiousLines.xls" Then
        MsgBox "指定されたファイルは、このマクロのファイル自身です。" _
        & Chr(13) & "このままマクロを終了します。"
        End
    End If
    
    アドレス = 指定セル.Address(ColumnAbsolute:=False)
    アドレス = Left(アドレス, InStr(アドレス, "$") - 1)
    シート = 指定セル.Parent.Name
    
    Call 並び替え重複行削除�B(対象ブック, シート, アドレス)

キャンセル:

End Sub


Private Sub 並び替え重複行削除�B(ブック名 As String, シート名 As String, 列名 As String)
    Dim 列セル名 As String
    Dim 処理中セル As Range
    Dim 次のセル As Range
    
    Workbooks(ブック名).Worksheets(シート名).Activate
    Application.ScreenUpdating = False

    列セル名 = 列名 & "1"
    
    Worksheets(シート名).Range(列セル名).Sort _
        Key1:=Worksheets(シート名).Range(列セル名)

    Set 処理中セル = Worksheets(シート名).Range(列セル名)
    Do While Not IsEmpty(処理中セル)
        Set 次のセル = 処理中セル.Offset(1, 0)
        If 次のセル.Value = 処理中セル.Value Then
            処理中セル.EntireRow.Delete
        End If
        Set 処理中セル = 次のセル
    Loop
    
    Application.ScreenUpdating = True
    Range("A1").Select

End Sub

   Range("A1").CurrentRegion.Sort _
      Key1:=Range("P2"), Order1:=xlAscending, _
      Key2:=Range("B2"), Order2:=xlAscending, _
      Header:=xlYes

   '頭2行は、タイトル行なので、3行目以降をソート対象とする
   'ソート・キーは、最大3つなので、2回に分けてソートする
   集計シート.Activate
   集計シート.Range(Cells(3, 1), Cells(集計シート最終行, 集計シート最終列)).Sort _
      Key1:=Range("D2"), Order1:=xlAscending, _
      Key2:=Range("F2"), Order2:=xlAscending, _
      Header:=xlNo

   集計シート.Range(Cells(3, 1), Cells(集計シート最終行, 集計シート最終列)).Sort _
      Key1:=Range("A2"), Order1:=xlAscending, _
      Key2:=Range("B2"), Order2:=xlAscending, _
      Key3:=Range("C2"), Order3:=xlAscending, _
      Header:=xlNo

Rows(開始行番号 & ":" & 終了行番号).Delete Shift:=xlUp

   ThisWorkbook.Worksheets("Sheet1").Activate
   
   '既存シート内容を削除
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   If 最終行 > 1 Then
      Rows(2 & ":" & 最終行).Delete Shift:=xlUp
   End If

Range("A6:C" & CStr(最終行)).Delete Shift:=xlUp

Sub Macro()
    Worksheets("Sheet1").UsedRange.Sort Key1:=Range("D1"), Order1:=xlAscending, _
    Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        SortMethod:=xlPinYin, DataOption1:=xlSortNormal
End Sub