SSブログ

[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


-----[PR]-----





-----------【PR】-------------

nice!(0)  コメント(0)  トラックバック(0) 
共通テーマ:パソコン・インターネット

nice! 0

コメント 0

コメントを書く

お名前:
URL:
コメント:
画像認証:
下の画像に表示されている文字を入力してください。

Facebook コメント

トラックバック 0

トラックバックの受付は締め切りました

この広告は前回の更新から一定期間経過したブログに表示されています。更新すると自動で解除されます。