[VBA覚書]関数サンプル 1.Excel操作 その1 [VBA覚書]
VBAマクロで色々作ってる内に使い勝手が良かった関数
①レンジの取得
②シートの操作
--①レンジの取得「サンプルコード」----------------------------------------------------------
↓のように冗長になるのを避けたくて作成した関数
Set objRange = objSheet.Range(objSheet.Cells(stRow, stCol), objSheet.Cells(edRow, edCol))
「例)使い方」
Private Sub procRange()
Dim objRange As Range
Dim objSheet As Worksheet
Set objSheet = ThisWorkbook.Worksheets("Sheet1")
''1行目の2列目から3行目の4列目までを取得する
Set objRange = Range(GetAddr(1, 2, 3, 4))
''列番号は英字でも可能
Set objRange = Range(GetAddr(1, "A", 3, "D"))
''----------------------
''終了位置は省略可能
''----------------------
''4行目のA列のみを取得
Set objRange = Range(GetAddr(4, "A"))
''5行目のA列~D列を取得
Set objRange = Range(GetAddr(5, "A", , "D"))
''1行目~6行目のG列を取得
Set objRange = Range(GetAddr(6, "G", 1))
End Sub
'***********************************************************************************
' 関数名 :getAddr
' 機能 :ワークシートのレンジ指定文字列を生成する
' 引数 :開始行、開始列、(終了行)、(終了列)
' 戻り値 :レンジ指定文字列
'***********************************************************************************
Public Function GetAddr(sr As Variant, sc As Variant, Optional er As Variant = 0, Optional ec As Variant = 0) As String
''終了位置が0の場合は開始位置を終了位置に設定する
If er = 0 Then er = sr
If ec = 0 Then ec = sc
GetAddr = Range(Cells(sr, sc), Cells(er, ec)).Address
End Function
--②シートの取得「サンプルコード」----------------------------------------------------------
「例)使い方」
Private Sub procSheet()
Dim objBook As Workbook
Dim newSheet As Worksheet
Dim cpySheet As Worksheet
''ブックを取得する
Set objBook = ThisWorkbook
''コピー元のシートを取得する
Set cpySheet = ExistsWorkSheet("COPY")
''コピー先のシートを取得する
Set newSheet = ExistsWorkSheet("NEW")
If newSheet Is Nothing Then
''コピー先のシートが無い場合
Set newSheet = AddWorkSheet(cpySheet, "New", 0, objBook)
End If
Call WorkSheetDelete("COPY,Sheet", 1, objBook)
End Sub
'***********************************************************************************
' 関数名 :ExistsWorkSheet
' 機能 :指定されたシートがあればシートオブジェクトを返却する
' 引数 :シート名、(対象ブック)
' 戻り値 :存在する場合、シートオブジェクトを返す。無い場合はNothing
'***********************************************************************************
Public Function ExistsWorkSheet(sheetName As String, _
Optional objBook As Workbook = Nothing) As Worksheet
On Error GoTo err_
Set ExistsWorkSheet = Nothing
''ブック未指定時は現在のアクティブブックを対象とする
If objBook Is Nothing Then Set objBook = ActiveWorkbook
Set ExistsWorkSheet = objBook.Worksheets(sheetName)
err_:
End Function
'***********************************************************************************
' 関数名 :AddWorkSheet
' 機能 :シートを作成する,追加位置(0:末尾、1:先頭)
' 引数 :コピー元シート、追加するシートの名称、
' (追加位置:未設定の場合は末尾)、(対象ブック)
' 戻り値 :作成したシートオブジェクト
'***********************************************************************************
Public Function AddWorkSheet(tmpSheet As Worksheet, _
sheetName As String, _
Optional addPos As Integer = 0, _
Optional objBook As Workbook = Nothing) As Worksheet
''確認メッセージを抑制する
Application.DisplayAlerts = False
''ブック未指定時は現在のアクティブブックを対象とする
If objBook Is Nothing Then Set objBook = ActiveWorkbook
''シートを挿入する
If addPos = 0 Then
''末尾に挿入する
tmpSheet.Copy after:=objBook.Worksheets(objBook.Worksheets.Count)
Else
''先頭に挿入する
tmpSheet.Copy before:=objBook.Worksheets(1)
End If
''挿入されたシート名を設定する
ActiveSheet.Name = sheetName
''挿入されたシートを返却する
Set AddWorkSheet = ActiveSheet
''確認メッセージの抑制を解除する
Application.DisplayAlerts = True
End Function
'***********************************************************************************
' 関数名 :WorkSheetDelete
' 機能 :シート名に指定された文字を含む(または含まない)シートを削除する
' 引数 :削除するシート名、(0:含むシート、1:含まないシート)、(対象ブック)
'***********************************************************************************
Public Sub WorkSheetDelete(strNames As String, _
Optional bFlg As Integer = 0, _
Optional objBook As Workbook = Nothing)
Dim objsheet As Worksheet
Dim i As Integer
Dim flg As Boolean
Dim aryNames As Variant
''ブック未指定時は現在のアクティブブックを対象とする
If objBook Is Nothing Then Set objBook = ActiveWorkbook
''確認メッセージを抑制する
Application.DisplayAlerts = False
''削除するシート名をカンマで区切って配列に格納する
aryNames = Split(strNames, ",")
If bFlg = 0 Then
''指定文字を含むシートを削除する
For Each objsheet In Worksheets
''全シートをループする
For i = LBound(aryNames) To UBound(aryNames)
''対象シート名の配列数分ループする
If InStr(objsheet.Name, aryNames(i)) > 0 Then
''シート名が対象文字列を含む場合はシートを削除する
objsheet.Delete
Exit For
End If
Next i
Next objsheet
Else
''指定文字を含まないシートを削除する
For Each objsheet In Worksheets
For i = LBound(aryNames) To UBound(aryNames)
''シート名に対象文字列が含まれているか確認する
flg = InStr(objsheet.Name, aryNames(i))
If flg Then
''含まれていた場合ループを抜ける
Exit For
End If
Next i
''対象文字列が含まれていないシートを削除する
If flg = False Then objsheet.Delete
Next objsheet
End If
''確認メッセージの抑制を解除する
Application.DisplayAlerts = True
End Sub
①レンジの取得
②シートの操作
--①レンジの取得「サンプルコード」----------------------------------------------------------
↓のように冗長になるのを避けたくて作成した関数
Set objRange = objSheet.Range(objSheet.Cells(stRow, stCol), objSheet.Cells(edRow, edCol))
「例)使い方」
Private Sub procRange()
Dim objRange As Range
Dim objSheet As Worksheet
Set objSheet = ThisWorkbook.Worksheets("Sheet1")
''1行目の2列目から3行目の4列目までを取得する
Set objRange = Range(GetAddr(1, 2, 3, 4))
''列番号は英字でも可能
Set objRange = Range(GetAddr(1, "A", 3, "D"))
''----------------------
''終了位置は省略可能
''----------------------
''4行目のA列のみを取得
Set objRange = Range(GetAddr(4, "A"))
''5行目のA列~D列を取得
Set objRange = Range(GetAddr(5, "A", , "D"))
''1行目~6行目のG列を取得
Set objRange = Range(GetAddr(6, "G", 1))
End Sub
'***********************************************************************************
' 関数名 :getAddr
' 機能 :ワークシートのレンジ指定文字列を生成する
' 引数 :開始行、開始列、(終了行)、(終了列)
' 戻り値 :レンジ指定文字列
'***********************************************************************************
Public Function GetAddr(sr As Variant, sc As Variant, Optional er As Variant = 0, Optional ec As Variant = 0) As String
''終了位置が0の場合は開始位置を終了位置に設定する
If er = 0 Then er = sr
If ec = 0 Then ec = sc
GetAddr = Range(Cells(sr, sc), Cells(er, ec)).Address
End Function
--②シートの取得「サンプルコード」----------------------------------------------------------
「例)使い方」
Private Sub procSheet()
Dim objBook As Workbook
Dim newSheet As Worksheet
Dim cpySheet As Worksheet
''ブックを取得する
Set objBook = ThisWorkbook
''コピー元のシートを取得する
Set cpySheet = ExistsWorkSheet("COPY")
''コピー先のシートを取得する
Set newSheet = ExistsWorkSheet("NEW")
If newSheet Is Nothing Then
''コピー先のシートが無い場合
Set newSheet = AddWorkSheet(cpySheet, "New", 0, objBook)
End If
Call WorkSheetDelete("COPY,Sheet", 1, objBook)
End Sub
'***********************************************************************************
' 関数名 :ExistsWorkSheet
' 機能 :指定されたシートがあればシートオブジェクトを返却する
' 引数 :シート名、(対象ブック)
' 戻り値 :存在する場合、シートオブジェクトを返す。無い場合はNothing
'***********************************************************************************
Public Function ExistsWorkSheet(sheetName As String, _
Optional objBook As Workbook = Nothing) As Worksheet
On Error GoTo err_
Set ExistsWorkSheet = Nothing
''ブック未指定時は現在のアクティブブックを対象とする
If objBook Is Nothing Then Set objBook = ActiveWorkbook
Set ExistsWorkSheet = objBook.Worksheets(sheetName)
err_:
End Function
'***********************************************************************************
' 関数名 :AddWorkSheet
' 機能 :シートを作成する,追加位置(0:末尾、1:先頭)
' 引数 :コピー元シート、追加するシートの名称、
' (追加位置:未設定の場合は末尾)、(対象ブック)
' 戻り値 :作成したシートオブジェクト
'***********************************************************************************
Public Function AddWorkSheet(tmpSheet As Worksheet, _
sheetName As String, _
Optional addPos As Integer = 0, _
Optional objBook As Workbook = Nothing) As Worksheet
''確認メッセージを抑制する
Application.DisplayAlerts = False
''ブック未指定時は現在のアクティブブックを対象とする
If objBook Is Nothing Then Set objBook = ActiveWorkbook
''シートを挿入する
If addPos = 0 Then
''末尾に挿入する
tmpSheet.Copy after:=objBook.Worksheets(objBook.Worksheets.Count)
Else
''先頭に挿入する
tmpSheet.Copy before:=objBook.Worksheets(1)
End If
''挿入されたシート名を設定する
ActiveSheet.Name = sheetName
''挿入されたシートを返却する
Set AddWorkSheet = ActiveSheet
''確認メッセージの抑制を解除する
Application.DisplayAlerts = True
End Function
'***********************************************************************************
' 関数名 :WorkSheetDelete
' 機能 :シート名に指定された文字を含む(または含まない)シートを削除する
' 引数 :削除するシート名、(0:含むシート、1:含まないシート)、(対象ブック)
'***********************************************************************************
Public Sub WorkSheetDelete(strNames As String, _
Optional bFlg As Integer = 0, _
Optional objBook As Workbook = Nothing)
Dim objsheet As Worksheet
Dim i As Integer
Dim flg As Boolean
Dim aryNames As Variant
''ブック未指定時は現在のアクティブブックを対象とする
If objBook Is Nothing Then Set objBook = ActiveWorkbook
''確認メッセージを抑制する
Application.DisplayAlerts = False
''削除するシート名をカンマで区切って配列に格納する
aryNames = Split(strNames, ",")
If bFlg = 0 Then
''指定文字を含むシートを削除する
For Each objsheet In Worksheets
''全シートをループする
For i = LBound(aryNames) To UBound(aryNames)
''対象シート名の配列数分ループする
If InStr(objsheet.Name, aryNames(i)) > 0 Then
''シート名が対象文字列を含む場合はシートを削除する
objsheet.Delete
Exit For
End If
Next i
Next objsheet
Else
''指定文字を含まないシートを削除する
For Each objsheet In Worksheets
For i = LBound(aryNames) To UBound(aryNames)
''シート名に対象文字列が含まれているか確認する
flg = InStr(objsheet.Name, aryNames(i))
If flg Then
''含まれていた場合ループを抜ける
Exit For
End If
Next i
''対象文字列が含まれていないシートを削除する
If flg = False Then objsheet.Delete
Next objsheet
End If
''確認メッセージの抑制を解除する
Application.DisplayAlerts = True
End Sub
-----[PR]-----
-----------【PR】-------------
コメント 0