Set1-XXX

Excel VBA Base Book
2023.05.05

Base Procedure Set 1

  1. 下記ボックス内をコピーし、標準モジュールに貼り付ける。
  2. モジュール名を【XXX_MakeBase】に変更する。
　モジュール名：XXX_MakeBase
Option Explicit　

'*****************************************************
'     MaxRow , MaxColの取得
'*****************************************************
Sub exeMax()

    Dim shtName As String    'シート名
    Dim i As Long
　　Dim j As Long
    Dim r As Long
    Dim c As Long
    Dim rMaxRow As Long
    Dim MaxRow As Long        '最終行
    Dim MaxCol As Long        '最終列　

    With ActiveSheet
    　　'通常使用
        'A列基準最終行取得
        MaxRow = .Cells(Rows.Count, 1).End(xlUp).Row
        '1行目基準最終列取得
        MaxCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        '使用済み範囲の最終行、最終列
        With .UsedRange
            MaxRow = .Rows(.Rows.Count).Row
            MaxCol = .Columns(.Columns.Count).Column
        End With
        '------------------------------------------------------------------
        '使用済み範囲の最終行が実際より大きい場合
        'Dim j As Long
        'Dim r As Long
        'Dim MaxRow As Long
        'Dim rMaxAs Long
        With .UsedRange
            'MaxRow = .Rows(.Rows.Count).Row
            MaxCol = .Columns(.Columns.Count).Column
        End With
        MaxRow = 0     '初期化
　　　　　　For j =1 to MaxCol
            rMaxRow = .Cells(Rows.Count, j).End(xlUp).Row
            If rMaxRow > MaxRow Then
　　　　　　    MaxRow ＝rMaxRow
　　　　　　End If
        Next j
        '------------------------------------------------------------------
        '対象テーブル最終セルの最終行、最終列
        MaxRow = .Cells(5, 1).End(xlDown).Row
        MaxCol = .Cells(5, 1).End(xlToRight).Column
        'アクティブセルを含むデータ範囲
        '「Ctrl」＋「Shift」＋ [*]キー(テンキーではないほうの*）で
        '選択される範囲
        With .UsedRange
            .Cells(r, c).CurrentRegion.Select
        End With
        '使用済み範囲の選択
        '1.アクティブセルをセルA1に移動します
        '2.[Ctrl]+[Shift］キーを押しながら［End」キーを押します
        .Range(.Cells(1, 1), .Cells(1, 1).SpecialCells(xlLastCell)).Select　
        '■スクロールして先頭に移動する
        Application.GoTo Reference:=.Range("A1"), Scroll:=True
　　　　End With
End Sub 
'=====================================================
'     シンプルな黒の罫線
'     Range ("A1:C3").Borders.LineStyle = xlContinuous
'===================================================== 
'*****************************************************
'     範囲 参照用
'*****************************************************
Sub Basic()
    Dim Rng As Range       '範囲
    With ActiveSheet
        '通常使用
        Set Rng = .Range(.Cells(1, 1), Cells(3, 2))    'セルA1-B3の範囲
        Set Rng = .Range("A1")                         'セルA1
        Set Rng = .Range("名前定義")                   '名前定義の範囲
        Set Rng = .Range("A1 : B3")                    'セルA1-B3の範囲
        Set Rng = .Range("A1, B3")                     'セルA1,B3の範囲
        Set Rng = .Range(.Rows(1), .Rows(3))           '1-3行の範囲
        Set Rng = .Range(.Columns(1), .Columns(3))     'A-C列の範囲
        Set Rng = .Range("1:3")                        '1-3行の範囲
        Set Rng = .Range("A:C")                        '1-3列の範囲
        Set Rng = .Rows(5)                             '5行目の範囲
        Set Rng = .Rows("1:5")                         '1-5行目の範囲
        Set Rng = .Columns(3)                          '3列の範囲
        Set Rng = .Columns("C")                        '3列の範囲
        Set Rng = .Columns("A: C")                     '1-3列の範囲
        'x : .Columns("1:3")                           '使えないNG
    End With
End Sub

'*****************************************************
'     シート存在確認
'*****************************************************
Public Function IsSht(shtName As String) As Boolean
    Dim sht As Worksheet　
    IsSht =False
    For Each sht In ActiveWorkbook.Worksheets
        If sht.Name = shtName Then
            IsSht = True
            Exit Function
        End If
    Next sht
End Function 

'+++***********************************************+++
'     シート検出
'     Call IsShtOwb(shtName, wbName )
'+++***********************************************+++
Public Function IsShtOwb(shtName As String, wbName As String) As Boolean
   
　　Dim sht As Worksheet
    Dim Owb As Workbook

    IsShtOwb = False
    Set Owb = Workbooks(wbName)
    For Each sht In Owb.Worksheets
        If sht.Name = shtName Then
            IsShtOwb = True
            Set Owb = Nothing
            Exit Function
        End If
    Next sht
    'エラーを無視
    On Error Resume Next
    Set Owb = Nothing
    'エラー制御を戻す
    On Error GoTo 0
End Function

'*****************************************************
'     別のブックを開いて処理
'*****************************************************
Sub SampleBookOpen()

    Dim buf As String
    Dim TargetName As String
    Dim TargetBook As Workbook
    Dim wb As Workbook
    Dim Target As String
　　Dim IsOpen As Boolean　

    Target = "C:xxx\myBook.xlsx"
    TargetName = "myBook"　

    Call StopUpdating
　　　
    buf = Dir(Target)　
　　'ファイルの存在チェック
    If buf = "" Then
        MsgBox Target & vbCrLf & "は存在しません。", _
            vbExclamation
        Exit Sub
    Else
        '読み取りで良い場合
　      For Each wb In Workbooks
            If wb.Name = TargetName Then
                Set TargetBook = wb
            End If
        Next wb
        If IsOpen =False Then
            'ここでブックを開く
            Set TargetBook = Workbooks.Open(Target)
        End If
    End If　

   '対象ファイルへの処理
   '開いたブックを変更なしで閉じる
    TargetBook.Close savechanges := False

    Call Updating　
End Sub

'*****************************************************
'     フォルダ内すべてのファイル処理
'*****************************************************
Sub SampleAllFilePros()

    Dim buf As String
    Dim myPath As String
    Dim Cnt As Long
    
    myPath = "C: \Sample"
    buf = Dir(myPath & "\*.xls?")
    Do While buf <> ""
        Cnt = Cnt + 1
        Cells(Cnt, 1) = buf
        buf = Dir()
    Loop
End Sub

'*****************************************************
'     strMyVlook:対象：文字列
'     Call strMyVlook (skey, strRng, myN)
'     LngMyVlook（探す文字，A2:B8, 2)
'*****************************************************
Public Function strMyVlook(skey As String, strRng As String, myN As Long)
    Dim vRng As Range
　　'エラーを無視
    On Error Resume Next
    Set vRng = Range(strRng)　
　　'存在確認
    If WorksheetFunction.CountIf(vRng, skey) > 0 Then
        strMyVlook = Application.WorksheetFunction.VLookup(skey, vRng, myN, False)
    End If
 　 'エラー制御を戻す
    On Error GoTo 0
End Function　

'*****************************************************
'     lngMyVlook:対象：数字
'     Call lngMyVlook(lngkey, strRng, myN)
'     LngMyVlook（探す数字，A2:B8, 2)
'*****************************************************
Public Function lngMyVlook(lngkey As Long, strRng As String, myN As Long)
    Dim vRng As Range　

    'エラーを無視
    On Error Resume Next
    Set vRng = Range(strRng) 
　　'存在確認
    If WorksheetFunction.CountIf(vRng, lngkey) > 0 Then
        lngMyVlook = Application.WorksheetFunction.VLookup(lngkey, vRng, myN, False)
    End If
 　 'エラー制御を戻す
    On Error GoTo 0

End Function

'*****************************************************
'     図形の位置と名前を取得
'*****************************************************
Public Sub TopAndLeftSample()
    Dim shp As Shape
    'アクティブシート内の図形/画像の左、上の位置を取得
    For Each shp In ActiveSheet.Shapes
        Debug.Print shp.Name & ":" & (shp.Left) & "." & (shp.Top)
    Next shp
End Sub　

'*****************************************************
'     図形の位置と名前を取得2
'*****************************************************
Public Sub TopAndLeftSample2()
    Dim shp As Shape 
    'アクティブシート内の図形/画像の中心位置をピクセル単位で取得
    For Each shp In ActiveSheet.Shapes
        Debug.Print shp.Name & ":" & (shp.Left + shp.Width / 2) & "," _
                                                & (shp.Top + shp.Height / 2)
     Next shp
End Sub　

'*****************************************************
'     空白行削除
'     下記コードの前に､
'     Columns (2).Select  等 記載
'*****************************************************
Sub DelNullRows()
    Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub　

'*****************************************************
'     空白セル削除
'     下記コードの前に､
'     Columns (2).Select  等 記載
'*****************************************************
Sub DelNullCells()
    Selection.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End Sub　

'*****************************************************
'     Find関数設定Test
'*****************************************************
Sub TestFind()
    Debug.Print FindRow("Main", "A:C", "合計", xlValues)
    Debug.Print FindRow("Main", "A:C", "個人 計", xlValues)
End Sub　

'*****************************************************
'     Find関数設定
'     Find関数で､ データを検索し、その行番号を返す
'     引数:対象シート､対象列､検索データ､検索形式
'     (LookIn:xlFormula:数式,xlValues:値,xlComents:コメント文）
'     (LookAt:xlPart:部分一致,xlwhole:全体一致するセルを検索）
'     戻り値: 行番号
'     FRow =FindRow ("Main","A","what",xlValues)
'*****************************************************
Public Function FindRow(shtName As String, sCol As String, ChkData As Variant, _
                        varLookIn As Variant) As Long
    Dim tgtSht As WorkSheet 
    On Error Resume Next
    FindRow = 0 

    Set tgtSht = ThisWorkbook.Worksheets(shtName)
    With tgtSht
        If WorksheetFunction.CountIf(.Columns(sCol), ChkData) > 0 Then
            FindRow = .Columns(sCol).Find(What:=ChkData, _
                             LookIn:=varLookIn, LookAt:=xlPart).Row
        End If
    End With 
    Set tgtSht = Nothing
End Function　

'*****************************************************
'     Find関数設定
'     Find関数で､ データを検索し、その列番号を返す
'     引数:対象シート､対象列､検索データ､検索形式
'     (Lookln:xlFormula:数式,xlValues:値,xlComents:コメント文）
'     (LookAt:xlPart:部分一致,xlwhole:全体一致するセルを検索）
'     戻り値: 列番号
'     FCol =FindCol ("Main", 2, "what", xlValues)
'*****************************************************
Public Function FindCol(shtName As String, iRow As Long, ChkData As Variant, _
                        varLookIn As Variant) As Long

    Dim tgtSht As WorkSheet
    On Error Resume Next
    FindCol = 0 
    
    Set tgtSht = ThisWorkbook.Worksheets(shtName)
    With tgtSht
        If WorksheetFunction.CountIf(.Rows(iRow), ChkData) > 0 Then
            FindCol = .Rows(iRow).Find(What:=ChkData, _
                                LookIn:=varLookIn, LookAt:=xlPart).Column
        End If
    End With 
    Set tgtSht = Nothing
End Function　

'*****************************************************
'     SortSample
'*****************************************************
Sub SampleSort()
    Dim ws As Worksheet
    Dim SortRng As Range　

    Set ws = ActiveSheet 

    'ActiveSheet 以外､Select必須
    With ws.Sort
        '昇順に並び替え
        With .SortFields
 　　　　　'既存情報をクリア
            .Clear
            .Add Key:=ws.Range("A1"), Order:=xlAscending
            .Add Key:=ws.Range("B1"), Order:=xlAscending
        End With
        .SetRange ws.Range("A1:J11")
        .Header = xlYes
        .Apply
        Call　exeBreak
    End With

End Sub　

'*****************************************************
'     グレーの罫線
'     Call MyLinestyleG(ShtName，上行、左列、下行、右列）
'*****************************************************
Function MyLineStyleG(shtName As String, LR As Long, _
                      LC As Long, RR As Long, RC As Long)
    With ThisWorkbook.Worksheets(shtName)
        With .Range(.Cells(LR, LC).Cells(RR, RC)).Borders
            .LineStyle = xlContinuous
            .ColorIndex = 16
            .Weight = xlThin
        End With
    End With　

End Function　

'*****************************************************
'     黒の罫線
'     Call MyLinestyle(ShtName，上行、左列、下行、右列）
'*****************************************************
Function MyLineStyle(shtName As String, LR As Long, _
                     LC As Long, RR As Long, RC As Long)

    With ThisWorkbook.Worksheets(shtName)
        With .Range(.Cells(LR, LC).Cells(RR, RC)).Borders
            .LineStyle = xlContinuous
            .ColorIndex = 1
            .Weight = xlThin
        End With
    End With

End Function

'*****************************************************
'     グレーの罫線  外枠
'     Call ThickLine(ShtName，上行、左列、下行、右列）
'*****************************************************
Function ThickLine(shtName As String, LR As Long, _
                   LC As Long, RR As Long, RC As Long)

    With ThisWorkbook.Worksheets(shtName)
        .Range(.Cells(LR, LC).Cells(RR, RC)).BorderAround _
            LineStyle:=xlContinuous, _
            Weight:=xlThick
    End With

End Function　

'*****************************************************
'     外枠 赤の点線
'     Call RedDotLine(ShtName，上行、左列、下行、右列）
'*****************************************************
Function RedDotLine(shtName As String, LR As Long, _
                    LC As Long, RR As Long, RC As Long)

    With ThisWorkbook.Worksheets(shtName)
        .Range(.Cells(LR, LC).Cells(RR, RC)).BorderAround _
            LineStyle:=xlDot, _
            Weight:=xlThick, _
            Color:=vbRed
    End With　

End Function　

'*****************************************************
'     不要なリンクを一括削除
'*****************************************************
 Sub CutLink()
    Dim vntLink As Variant
    Dim i As Long　

    vntLink = ThisWorkbook.LinkSources(Type:=xlLinkTypeExcelLinks)
    If IsArray(vntLink) Then
        For i = 1 To UBound(vntLink)
            ThisWorkbook.BreakLink Name:=vntLink(i), Type:=xlExcelLinks
        Next i
    End If　

 End Sub

'*****************************************************
'    アクティブセル 色情報取得
'*****************************************************
Public Sub GetRngColor()
    Debug.Print "背景色：" & ActiveCell.Interior.Color
    Debug.Print "文字色：" & ActiveCell.Font.Color
End Sub

コメント

タイトルとURLをコピーしました