自分用のメモなので、形は整ってないです。
1次元の配列の要素内で、重複しているものがあるかを調べるFunction。重複有りならTrue、重複無しならFalseをリターン
Function IsOverlapping(ByRef arrParam) As Boolean
'1次元の配列の要素内で、重複しているものがあるかを調べる。重複有りならTrue、重複無しならFalseをリターン
Dim i As Long
Dim j As Long
IsOverlapping = False '初期値にFalseを設定
For i = LBound(arrParam) To UBound(arrParam)
For j = LBound(arrParam) To UBound(arrParam)
If arrParam(i) = arrParam(j) And i <> j Then
IsOverlapping = True '重複があったらTrueに
End If
If IsOverlapping Then Exit For '重複があったらループを抜ける
Next j
If IsOverlapping Then Exit For
Next i
End Function
'整数・文字列・小数のデータで実行可能 文字列はバイナリモード比較
'重複の無い要素数10の配列を最後までチェックする処理を、10万回繰り返して、所要時間1～2秒くらい
フォルダ選択のダイアログを開き、選択されたフォルダのパスを引数で指定されたセルに格納する
Private Sub ShowSelectFolderDialog(ByVal lngRow As Long, ByVal lngColumn As Long)
'フォルダ選択のダイアログを開き、選択されたフォルダのパスを引数で指定されたセルに格納する
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
Cells(lngRow, lngColumn).Value = .SelectedItems(1) & "\"
Else
MsgBox "キャンセルされました"
End If
End With
End Sub
'Publicプロシージャにして、ボタンから直接呼ぶ形にしてもいいだろう
エクセルファイルを選択するダイアログを開き、選択されたフォルダのパスを引数で指定されたセルに格納する
Private Sub ShowSelectExcelFileDialog(ByVal lngRow As Long, ByVal lngColumn As Long)
'エクセルファイルを選択するダイアログを開き、選択されたフォルダのパスを引数で指定されたセルに格納する
Dim varFileName As Variant
varFileName = Application.GetOpenFilename _
("Excel ファイル (*.xls; *.xlsx; *.xlsm; *.xlsb),*.xls; *.xlsx; *.xlsm; *.xlsb")
If VarType(varFileName) = vbBoolean Then
MsgBox "キャンセルされました"
Else
Cells(lngRow, lngColumn).Value = CStr(varFileName)
End If
End Sub
'Publicプロシージャにして、ボタンから直接呼ぶ形にしてもいいだろう
ブックが既に開かれているかを判定する ネットワーク上のブックを誰かがひらいているかも判定できる
Public Function IsBookOpened(ByVal bookPath As String) As Boolean
On Error Resume Next
Open bookPath For Append As #1 '追加モードでブックを開く。実際にブックが開かれるわけではない
Close #1
If Err.Number <> 0 Then
IsBookOpened = True
'エラーが発生していれば、ブックのOpenに失敗している。他のユーザが既に開いていることになる
Else
IsBookOpened = False
End If
End Function
セルのInterior.Color、Font.Colorの数値から16進数文字列(FFAAFF 等)へ変換する
※単純にHex関数で変換すると、違う値になるので注意
Function ConvertColorNumberToHex(ByRef ws As Worksheet, ByVal row As Long, _
ByVal column As Long, ByVal isCellColor As Boolean) As String
'isCellColorがTrueでセルの背景色、Falseでフォント色
Dim colorNum As Long
Dim red As Long
Dim green As Long
Dim blue As Long
If isCellColor Then 'セルの背景色取得の場合
colorNum = ws.Cells(row, column).Interior.Color
Else
colorNum = ws.Cells(row, column).Font.Color 'フォント色
End If
red = colorNum Mod 256
green = Int(colorNum / 256) Mod 256
blue = Int(colorNum / 256 / 256)
ConvertColorNumberToHex = Right("0" & Hex(red), 2) & Right("0" & Hex(green), 2) & _
Right("0" & Hex(blue), 2)
End Function
結合セルを含むセル範囲の、データのある最終行・最終列を求める
※結合セルについては、結合範囲の右下のセルを最終セルとする
'********* 結合セルを含むセル範囲の、データのある最終行を求める *********
'ws 対象となるセルのワークシートオブジェクト
'startColumn 判定をする範囲の最初の列
'endColumn 判定をする範囲の最後の列
Public Function GetLastRowWithMergeCells(ByRef ws As Worksheet, ByVal startColumn As Long, _
ByVal endColumn As Long) As Long
Dim mergeRange As Range '結合している範囲
Dim i As Long
Dim lastRow As Long
Dim tmpNum As Long
lastRow = 1
For i = startColumn To endColumn
tmpNum = ws.Cells(ws.Rows.Count, i).End(xlUp).row
If ws.Cells(tmpNum, i).MergeCells = True Then '結合しているセルの場合
Set mergeRange = ws.Cells(tmpNum, i).MergeArea
tmpNum = mergeRange(mergeRange.Rows.Count, mergeRange.Columns.Count).row
'結合範囲の右下のセルの行番号を取得
End If
If lastRow < tmpNum Then
lastRow = tmpNum
End If
Next i
GetLastRowWithMergeCells = lastRow
End Function
'********* 結合セルを含むセル範囲の、データのある最終列を求める *********
'ws 対象となるセルのワークシートオブジェクト
'startRow 判定をする範囲の最初の行
'endRow 判定をする範囲の最後の行
Public Function GetLastColumnWithMergeCells(ByRef ws As Worksheet, ByVal startRow As Long, _
ByVal endRow As Long) As Long
Dim mergeRange As Range '結合している範囲
Dim i As Long
Dim lastColumn As Long
Dim tmpNum As Long
lastColumn = 1
For i = startRow To endRow
tmpNum = ws.Cells(i, ws.Columns.Count).End(xlToLeft).column
If ws.Cells(i, tmpNum).MergeCells = True Then '結合しているセルの場合
Set mergeRange = ws.Cells(i, tmpNum).MergeArea
tmpNum = mergeRange(mergeRange.Rows.Count, mergeRange.Columns.Count).column
'結合範囲の右下のセルの列番号を取得
End If
If lastColumn < tmpNum Then
lastColumn = tmpNum
End If
Next i
GetLastColumnWithMergeCells = lastColumn
End Function
ファイルやフォルダのパスが正しいかどうかをチェックするFunction (空白、\で始まる等)
'ファイルやフォルダのパスが正しいかどうかをチェックする
'チェックの結果により、以下の整数値をリターン
'0:異常なし
'1:パスが空文字
'2:存在しないパス
'3:「\」で始まるパス
'4:「.」で始まるパス
'5:「/」で始まるパス
'path フォルダ･ファイルのフルパス
'isFolder フォルダのパスである場合はTrue、ファイルのパスはFalseを指定する
Public Function ValidateDirectoryPath(ByVal path As String, ByVal isFolder As Boolean) As Long
ValidateDirectoryPath = 0 '初期値は異常なし
If path = "" Then
ValidateDirectoryPath = 1
Exit Function
End If
If Left(path, 1) = "\" Then
ValidateDirectoryPath = 3
Exit Function
End If
If Left(path, 1) = "." Then
ValidateDirectoryPath = 4
Exit Function
End If
If Left(path, 1) = "/" Then
ValidateDirectoryPath = 5
Exit Function
End If
If isFolder Then 'フォルダのパスである場合
If xFSO.FolderExists(path) = False Then
ValidateDirectoryPath = 2
Exit Function
End If
Else
If xFSO.FileExists(path) = False Then
ValidateDirectoryPath = 2
Exit Function
End If
End If
End Function
Excelファイルの全シート名を、コンボボックスの要素として格納する例
これで完璧かどうかは自信無し
'*********** 以下のコードは、フォームのコード内にある
Private Sub btnGetSheetNames_Click()
Call GetSheetNames
End Sub
Private Sub GetSheetNames()
'Excelファイルのパスが入っているテキストボックスのコントロール名 txtExcelFilePath
'シート名のリストを格納するコンボボックスのコントロール名 cmbSheetNames
Dim wb As Workbook
Dim targetBook As Workbook 'シート名を取得するブック
Dim ws As Worksheet
Dim bookPath As String
Dim isAlreadyOpen As Boolean 'すでに対象となるブックが開かれているか
On Error GoTo GetSheetNames_EH
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set targetBook = Nothing
isAlreadyOpen = False
If Me.txtExcelFilePath.Text = "" Then
MsgBox "「Excelファイルのパス」が空白です"
Call LastProcess
Exit Sub
Else
bookPath = Me.txtExcelFilePath.Text
End If
If Dir(bookPath) = "" Then
MsgBox "「Excelファイルのパス」」で指定されたExcelファイルは存在しません"
Call LastProcess
Exit Sub
End If
For Each wb In Workbooks '現在開いているブックを走査
If wb.Path & "\" & wb.Name = bookPath Then
' 同パスのものがある場合はすでに開いているので、そのブックを対象にする
Set targetBook = wb
isAlreadyOpen = True
Exit For
End If
If wb.Name = Dir(bookPath) Then ' 同名のブックが開かれている場合
MsgBox "「Excelファイルのパス」」で指定されたExcelファイルと同名のファイルが開かれています" _
& vbCrLf & "同名のファイルを閉じてからやり直してください"
Call LastProcess
Exit Sub
End If
Next wb
If targetBook Is Nothing Then 'まだ対象となるブックが開かれていない場合
Workbooks.Open Filename:=bookPath, UpdateLinks:=0, ReadOnly:=True
'読み取り専用、リンク更新無しでブックを開く
Set targetBook = ActiveWorkbook
End If
Me.cmbSheetNames.Clear 'コンボボックスの全要素をクリア
For Each ws In targetBook.Worksheets
Me.cmbSheetNames.AddItem ws.Name
'シート名を「データのあるシート」のコンボボックスの要素として追加
Next ws
If isAlreadyOpen = False Then
'すでに対象となるブックが開かれていた場合は、ブックを閉じない
targetBook.Close
End If
Call LastProcess
Exit Sub
GetSheetNames_EH:
MsgBox "エラー発生"
Call LastProcess
End Sub
Private Sub LastProcess()
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Windowsのディレクトリ名に使えない文字( \ / : * ? " < > | )が、文字列中に含まれるかを判定する
'Windowsのディレクトリに使えない文字が含まれるかを判定する。含まれる場合はTrueをリターン
Private Function existsInvalidString(ByVal pStr As String) As Boolean
existsInvalidString = False
If InStr(pStr, "\") <> 0 Then
existsInvalidString = True
Exit Function
End If
If InStr(pStr, "/") <> 0 Then
existsInvalidString = True
Exit Function
End If
If InStr(pStr, ":") <> 0 Then
existsInvalidString = True
Exit Function
End If
If InStr(pStr, "*") <> 0 Then
existsInvalidString = True
Exit Function
End If
If InStr(pStr, "?") <> 0 Then
existsInvalidString = True
Exit Function
End If
If InStr(pStr, """") <> 0 Then
existsInvalidString = True
Exit Function
End If
If InStr(pStr, "<") <> 0 Then
existsInvalidString = True
Exit Function
End If
If InStr(pStr, ">") <> 0 Then
existsInvalidString = True
Exit Function
End If
If InStr(pStr, "|") <> 0 Then
existsInvalidString = True
Exit Function
End If
End Function
Sub ggg()
' 文字列中に \ / : * ? " < > | が含まれるかを判定
Debug.Print existsInvalidString("\")
Debug.Print existsInvalidString("￥")
Debug.Print existsInvalidString("a \あ")
Debug.Print "----------------------------------"
Debug.Print existsInvalidString("/")
Debug.Print existsInvalidString("／")
Debug.Print existsInvalidString("a /あ")
Debug.Print "----------------------------------"
Debug.Print existsInvalidString(":")
Debug.Print existsInvalidString("：")
Debug.Print existsInvalidString("a :あ")
Debug.Print "----------------------------------"
Debug.Print existsInvalidString("*")
Debug.Print existsInvalidString("＊")
Debug.Print existsInvalidString("a *あ")
Debug.Print "----------------------------------"
Debug.Print existsInvalidString("?")
Debug.Print existsInvalidString("？")
Debug.Print existsInvalidString("a ?あ")
Debug.Print "----------------------------------"
Debug.Print existsInvalidString("""")
'全角のダブルクォーテーションは指定できない?
Debug.Print existsInvalidString("a ""あ")
Debug.Print "----------------------------------"
Debug.Print existsInvalidString("<")
Debug.Print existsInvalidString("＜")
Debug.Print existsInvalidString("a <あ")
Debug.Print "----------------------------------"
Debug.Print existsInvalidString(">")
Debug.Print existsInvalidString("＞")
Debug.Print existsInvalidString("a >あ")
Debug.Print "----------------------------------"
Debug.Print existsInvalidString("|")
Debug.Print existsInvalidString("｜")
Debug.Print existsInvalidString("a |あ")
End Sub
サブフォルダまで検索するテンプレート 再帰を使用
Sub SearchSubFolderTemplate()
'サブフォルダまで検索するテンプレート
'「実行」シートには、サブフォルダまで検索するかを選択するチェックボックスがある
'「実行」シートには、フォルダ指定のボタンと実行ボタンがある
Dim folderPath As String
Dim bolSearchSubFolder As Boolean 'サブフォルダも検索するか
If Cells(3, 2) = "" Then
MsgBox "フォルダが指定されていません"
Exit Sub
Else
folderPath = Cells(3, 2)
End If
If Dir(folderPath, vbDirectory) = "" Then
MsgBox "指定されたフォルダは存在しません"
Exit Sub
End If
If Right$(folderPath, 1) <> "\" Then
'パスの最後に"\"が無い場合は付与する
folderPath = folderPath & "\"
End If
bolSearchSubFolder = ThisWorkbook.Worksheets("実行").checkSubFolder.Value
'サブフォルダまで検索するかを指定
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Call FileSearch(folderPath, bolSearchSubFolder)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "完了"
End Sub
Sub FileSearch(folderPath As String, bolSearchSubFolder As Boolean)
' ファイル検索を実行する(再帰処理型)
Dim xFSO As New FileSystemObject
Dim xFolder As Folder
Dim xFile As File
If bolSearchSubFolder Then
For Each xFolder In xFSO.GetFolder(folderPath).SubFolders
' サブフォルダを取得する
Call FileSearch(xFolder.Path, True)
' 再帰処理でサブフォルダまで検索
Next xFolder
End If
For Each xFile In xFSO.GetFolder(folderPath).Files
' ファイルを検索
If xFile.Name Like "*.xls*" Then ' エクセル型のファイルの場合
Debug.Print xFile.Path
End If
Next xFile
Set xFSO = Nothing
End Sub
Sub getFolderPath() 'フォルダを選択するダイアログを表示
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then ' フォルダが選択された場合
Cells(3, 2).Value = .SelectedItems(1) & "\"
Else
MsgBox "キャンセルされました"
End If
End With
End Sub
ユーザーコードを入力するテキストボックスの値の変化に応じて、他のコントロールの表示も変化させる例
インポートファイルは、
ExcelVBA関係\インポートファイル\テキストボックスの値の変化でデータの表示も変わるフォームの例
のディレクトリに保存してある
*********** フォームのコード ****************
Private arrAllUserData() As String
'全てのユーザーデータを取得して格納する arrAllUserData(1 To 4,0)の形式
'1次元 (1) ユーザーコード
'1次元 (2) ユーザー名
'1次元 (3) 登録日
'1次元 (4) 所属部署
'2次元は可変長
Private arrSingleUserDataMatchesUserCode(1 To 4) As String
'指定されているユーザーコードに該当するユーザーデータを格納する
'(1) ユーザーコード
'(2) ユーザー名
'(3) 登録日
'(4) 所属部署
'フォーム初期化時
Private Sub UserForm_Initialize()
Erase arrAllUserData
Erase arrSingleUserDataMatchesUserCode
ReDim arrAllUserData(1 To 4, 0) '動的配列はここで初期化したほうがいい
Call GetAllUserData(arrAllUserData) 'ユーザーデータを取得
End Sub
'ユーザーコードのテキストボックスの値が変化した時
Private Sub txtUserCode_Change()
'テキストボックスに入力されているユーザーコードのデータが存在するかをチェック
If CheckExistsUserData Then
Me.lblUserName.Caption = arrSingleUserDataMatchesUserCode(2)
Me.lblRegisterDate.Caption = arrSingleUserDataMatchesUserCode(3)
Me.lblPost.Caption = arrSingleUserDataMatchesUserCode(4)
Else
Me.lblUserName.Caption = "該当データ無し"
Me.lblRegisterDate.Caption = "該当データ無し"
Me.lblPost.Caption = "該当データ無し"
End If
End Sub
'「実行」ボタンが押された時
Private Sub btnExecute_Click()
If CheckExistsUserData Then
MsgBox "処理を開始しました"
Else
MsgBox "入力されているユーザーコードに該当するデータは存在しません"
End If
End Sub
'テキストボックスに入力されているユーザーコードのデータが存在するかをチェック
Private Function CheckExistsUserData() As Boolean
Dim userCode As String
Dim reg As Variant
Dim i As Long
CheckExistsUserData = False
Set reg = CreateObject("VBScript.RegExp")
userCode = Me.txtUserCode.Text 'ユーザーコードを入力するテキストボックス
With reg
.Global = True ' 文字列全体を検索
.IgnoreCase = False ' 大文字小文字を区別する
.Pattern = "^[0-9]{1,4}$"
If .Test(userCode) = False Then
Exit Function
End If
End With
Set reg = Nothing
userCode = Format(CLng(userCode), "0000") '0000 の形式にする
Call GetAllUserData(arrAllUserData) '全てのユーザーデータを取得
For i = LBound(arrAllUserData, 2) To UBound(arrAllUserData, 2)
If arrAllUserData(1, i) = userCode Then
CheckExistsUserData = True
arrSingleUserDataMatchesUserCode(1) = arrAllUserData(1, i)
arrSingleUserDataMatchesUserCode(2) = arrAllUserData(2, i)
arrSingleUserDataMatchesUserCode(3) = arrAllUserData(3, i)
arrSingleUserDataMatchesUserCode(4) = arrAllUserData(4, i)
Exit Function
End If
Next i
End Function
************* 標準モジュールのコード **********************
Private Enum SETTING '定数設定のEnum
dataStartRow = 3 'ユーザーデータがあるシートのデータ部分が始まる行
userCodeColumn = 2 'ユーザーコードの列
userNameColumn = 3 'ユーザー名の列
registerDateColumn = 4 '登録日の列
postColumn = 5 '所属部署の列
End Enum
'全てのユーザーデータを取得する。標準モジュールにあるプロシージャ
Public Sub GetAllUserData(ByRef arrAllUserData() As String)
Dim lastRow As Long
Dim i As Long
Erase arrAllUserData
ReDim arrAllUserData(1 To 4, 0)
lastRow = ユーザーデータ.Cells(ユーザーデータ.Rows.Count, SETTING.userCodeColumn).End(xlUp).Row
'データ部分オ最後の行番号を取得。"ユーザーデータ"はシートのオブジェクト名
If lastRow < SETTING.dataStartRow Then 'データが全く無い場合
Exit Sub '配列は空のまま終了にする
End If
For i = SETTING.dataStartRow To lastRow
arrAllUserData(1, UBound(arrAllUserData, 2)) = ユーザーデータ.Cells(i, SETTING.userCodeColumn).Value
arrAllUserData(2, UBound(arrAllUserData, 2)) = ユーザーデータ.Cells(i, SETTING.userNameColumn).Value
arrAllUserData(3, UBound(arrAllUserData, 2)) = CStr(ユーザーデータ.Cells(i, SETTING.registerDateColumn).Value)
arrAllUserData(4, UBound(arrAllUserData, 2)) = ユーザーデータ.Cells(i, SETTING.postColumn).Value
ReDim Preserve arrAllUserData(1 To 4, UBound(arrAllUserData, 2) + 1)
Next i
ReDim Preserve arrAllUserData(1 To 4, UBound(arrAllUserData, 2) - 1) '最後の要素は削除
End Sub
Sub ShowUserDataForm()
Load UserDataForm
UserDataForm.Show vbModal
End Sub