◎一例として下図のようなダイアログを作成
Option Explicit
Option Base 1
Option Private Module
Option Explicit
Option Private Module
'汎用的に使える関数を記載する
Function ChkSheet(strSheet As String) As Boolean
' シート存在チェック関数
' 引数 strSheet :存在を確認するシート名
' 戻り値 Boolean :True :存在した時
' :False:存在しない時
Dim ws As Worksheet
ChkSheet = False
For Each ws In Worksheets
If ws.Name = strSheet Then
ChkSheet = True
Exit For
End If
Next
End Function
Function JudgeSheetExist(ByVal TargetSheetName As String) As Boolean
'ターゲットシートの存在の有無を判定し、なかったらターゲット
'シートを作成する
'引数 TargetSheetName:シート名の文字列
'戻値 成功:True ,失敗:False
Dim errFlag As Boolean
Dim wksSheet As Worksheet
Dim strTarget As String
strTarget = TargetSheetName
errFlag = False
For Each wksSheet In Worksheets
If wksSheet.Name = strTarget Then
errFlag = True
Exit For
End If
Next
If errFlag <> True Then 'なかったら
'ターゲットシートを作成
Set wksSheet = Sheets.Add(after:=Worksheets(Worksheets.Count)) '一番最後に追加
wksSheet.Name = strTarget
errFlag = True
End If
'オブジェクト解放
Set wksSheet = Nothing
JudgeSheetExist = errFlag
End Function
Function SpecialDataInsert(ByVal TargetSheetName As String, ByVal InsertRow As Long, _
ByVal DataMatrix As Variant) As Boolean
'指定されたシートに指定レコード(2次元配列x,y)を最終行に追加する
'
'引数1:TargetSheetName シート名
'引数1:InsertRow 挿入開始行
'引数1:DataMatrix レコードを定義した配列
'戻値: 成功:TRUE 失敗:FALSE
Dim x, y As Long
Dim xMax As Long
Dim yMax As Long
Dim wksTargetSheet As Worksheet
On Error GoTo Hdl_SDI_ERROR 'エラー処理
Set wksTargetSheet = ThisWorkbook.Worksheets(TargetSheetName)
wksTargetSheet.Cells(1, 1).Select
xMax = UBound(DataMatrix, 1)
yMax = UBound(DataMatrix, 2)
For y = 1 To yMax Step 1
For x = 1 To xMax Step 1
wksTargetSheet.Cells(y + InsertRow, x).Value = DataMatrix(x, y)
Next
Next
SpecialDataInsert = True
Exit Function
Hdl_SDI_ERROR:
'オブジェクト解放
Set wksTargetSheet = Nothing
SpecialDataInsert = False
End Function
Function DeleteSheet(ByVal TargetSheetName As String, ByVal strActBookName As String) As Boolean
'指定したブックの指定シートの削除をする関数
'
Dim objActiveBook As Object
Dim objWorkSheet As Object
On Error GoTo Hdl_Del_ERROR
Application.DisplayAlerts = False
Set objActiveBook = Workbooks(strActBookName)
Set objWorkSheet = objActiveBook.Sheets(TargetSheetName)
objWorkSheet.Delete
Application.DisplayAlerts = True
DeleteSheet = True
Exit Function
Hdl_Del_ERROR:
Application.DisplayAlerts = True
Set objWorkSheet = Nothing
Set objActiveBook = Nothing
DeleteSheet = False
End Function
Function DeleteSheetFromPartialSheetName(ByVal MatchingWord As String, _
ByVal strActBookName As String) As Boolean
'指定ブックの部分一致文字列で指定したシートの削除をする関数
'
Dim objActiveBook As Object
Dim objWorkSheet As Object
Dim i As Integer 'カウンタ
Dim ShtName As String 'シート名
'エラー処理 & 警告無効
On Error GoTo Hdl_Del_ERROR
Application.DisplayAlerts = False
'ブック名のセット
Set objActiveBook = Workbooks(strActBookName)
'存在するか判定し、あったら削除
For Each objWorkSheet In objActiveBook.Worksheets
ShtName = objWorkSheet.Name
If ShtName Like "*" & MatchingWord & "*" Then
objWorkSheet.Delete
DeleteSheetFromPartialSheetName = True
End If
Next objWorkSheet
'警告を有効に
Application.DisplayAlerts = True
Exit Function
Hdl_Del_ERROR:
Application.DisplayAlerts = True
Set objWorkSheet = Nothing
Set objActiveBook = Nothing
DeleteSheetFromPartialSheetName = False
End Function
Function ConcatenateRangeText(ByRef objCells As Range) As String
'指定したセル範囲の文字列を連結するユーザー定義関数
'上記のコードをVBE(Visual Basic Editor)を起動して標準モジュールに
'貼り付ければ、普通のワークシート関数と同様に使えます。
'
'A1セルからA3セルにデータが入力されているときに、A4セルに
'「=ConcatenateRangeText(A1:A3)」と入力してやれば、
'A4セルにA1セルからA3セルのデータが連結される
'http://www.relief.jp/itnote/archives/001342.php 丸パクリ
'※スペースは除去するように変更
Dim objCell As Range
Dim strRet As String
strRet = ""
For Each objCell In objCells
strRet = strRet & objCell.Text
Next
strRet = Replace(strRet, " ", "")
ConcatenateRangeText = strRet
End Function
Public Sub ToggleSheetProtect()
'選択されているシートの保護を切り替える
'保護・保護解除がトグルで動作
Dim sh As Object
'選択したシートを列挙する
For Each sh In ActiveWindow.SelectedSheets
sh.Select 'そのシートを選択する
If sh.ProtectContents = True Then 'シートが保護の時
sh.Unprotect
Else 'シートが保護されてない時
sh.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End If
Next
End Sub
Function DeleteRecords(ByVal TargetBookPath As String, ByVal TargetCode As String, _
Optional ByVal TargetColumn As Long = 1) As Long
'指定ブックの指定列のセルに指定文字列があるレコードを削除する
'引数1:開くブック名(フルパス)
'引数2:指定する文字列(省略時1)
'引数3:削除対象のある列
'戻値:削除したレコード数(-1はエラー)
Dim i As Long
Dim strFlg As String
Dim lngRowNum As Long
Dim lngRowMax As Long
Dim lngCount As Long
Dim wksSheet As Worksheet
Dim strBookName As String
strBookName = Dir(TargetBookPath)
On Error GoTo Hdl_FileERROR
Workbooks.Open FileName:=(TargetBookPath)
Set wksSheet = Workbooks(strBookName).Worksheets(1)
On Error GoTo Hdl_DelERROR
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
wksSheet.Select
lngRowMax = wksSheet.UsedRange.Rows.Count
'行の削除を実施
lngRowNum = 1
lngCount = 0
Do
strFlg = CStr(wksSheet.Cells(lngRowNum, TargetColumn).Value)
If strFlg = CStr(TargetCode) Then '該当したら削除
wksSheet.Rows(lngRowNum).EntireRow.Delete
lngRowMax = lngRowMax - 1
lngCount = lngCount + 1 '削除した行をカウント
Else
lngRowNum = lngRowNum + 1 '該当しなければ次の行へ
End If
Loop Until lngRowNum = lngRowMax + 2
'閉じて保存して後始末
Application.DisplayAlerts = False
Workbooks(strBookName).Save
Workbooks(strBookName).Close
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
DeleteRecords = lngCount
Exit Function
Hdl_DelERROR:
Set wksSheet = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox lngRowNum & "行目の削除時にエラーが発生しました", vbCritical + vbOKOnly
DeleteRecords = -1
Exit Function
Hdl_FileERROR:
MsgBox "ファイルを開けませんでした", vbCritical + vbOKOnly
DeleteRecords = 0
End Function
Function DateCheck(ByVal mystr As String) As Boolean
'YYYYMMDD形式の文字列を判定する関数
'
DateCheck = False
'半角チェック
If mystr <> StrConv(mystr, vbNarrow) Then Exit Function
'文字長チェック
If Len(mystr) <> 8 Then Exit Function
'日付チェック
If IsDate(Left(mystr, 4) & "/" & Mid(mystr, 5, 2) & "/" & Right(mystr, 2)) Then
DateCheck = True
End If
End Function
|