Base Procedure Set 1
- 下記ボックス内をコピーし、標準モジュールに貼り付ける。
- モジュール名を【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
コメント