Option Base 1
''検索系↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓
'*************************************************************
'*
'* 指定された範囲から、指定された値を探して、見つかったRangeオブジェクトを順番にCollectionに格納して返す。
'* （※Findの仕様が変。なんで範囲の左上端をまず検出しない？？）
'* 見つからなかった場合はNothingを返す。
'*
'*************************************************************
Public Function fFindedCells(strTarget As String, rngTarget As Range) As Collection
Dim c As Range ' 検索結果
Dim firstAddress As String ' 最初に見つかったセルのアドレス
With rngTarget
Set c = .Find(What:=strTarget, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Set fFindedCells = New Collection
Do
fFindedCells.Add c
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
Else
Set fFindedCells = Nothing
End If
End With
Set c = Nothing
End Function
'*************************************************************
'*
'* 指定された範囲から、指定された値を探して、最初に見つかったRangeオブジェクトを返す。
'* 指定された範囲にあらかじめ見つけたい値が１つしかないと分かっているときに使用する。
'* 見つからなかった場合はNothingを返す。
'*
'*************************************************************
Public Function fFindedCell(strTarget As String, rngTarget As Range) As Range
Set fFindedCell = rngTarget.Find(What:=strTarget, LookIn:=xlValues)
End Function
'*************************************************************
'*
'* 指定されたセルの値が下方向にどこまで同じ値が入っているか調べる。
'* 同じ値を持つ最後のセルを返す。
'*
'*************************************************************
Public Function fLastRange_Vertical_SameValue_of(rng As Range, limitRowIndex As Long) As Range
Dim delta As Long
delta = 1
Do Until StrComp(rng.Value, rng.Offset(delta, 0).Value, vbBinaryCompare) <> 0 Or rng.Offset(delta, 0).row > limitRowIndex
delta = delta + 1
Loop
Set fLastRange_Vertical_SameValue_of = rng.Offset(delta - 1, 0)
End Function
''*************************************************************
''*
''* fLastRange_Vertical_SameValue_ofの横方向版。
''*
''*************************************************************
Public Function fLastRange_Horizonal_SameValue_of(rng As Range, limitColumnIndex As Integer) As Range
Dim delta As Integer
delta = 1
Do Until StrComp(rng.Value, rng.Offset(0, delta).Value, vbBinaryCompare) <> 0 Or rng.Offset(0, delta).column > limitColumnIndex
delta = delta + 1
Loop
Set fLastRange_Horizonal_SameValue_of = rng.Offset(0, delta - 1)
End Function
''行・列数系↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓
'*************************************************************
'*
'* 指定された列の最終行インデックスを返す。
'* すべてのセルに値が入っていなければ0を返す。
'*
'*************************************************************
Public Function fLastRowIndex(sht As Worksheet, inColumnIndex As Integer) As Long
fLastRowIndex = sht.Cells(sht.Rows.Count, inColumnIndex).End(xlUp).row
If ((fLastRowIndex = 1) And (IsEmpty(sht.Cells(fLastRowIndex, inColumnIndex)))) Then
fLastRowIndex = 0
End If
End Function
'*************************************************************
'*
'* 指定された行の最終列インデックスを返す。
'* すべてのセルに値が入っていなければ0を返す。
'*
'*************************************************************
Public Function fLastColumnIndex(sht As Worksheet, inRowIndex As Long) As Integer
fLastColumnIndex = sht.Cells(inRowIndex, sht.Columns.Count).End(xlToLeft).column
If ((fLastColumnIndex = 1) And (IsEmpty(sht.Cells(inRowIndex, fLastColumnIndex)))) Then
fLastColumnIndex = 0
End If
End Function
'*************************************************************
'*
'* 指定された列中で最終行インデックスの最大のものを返す。
'* 引数１ ：ワークシート
'* 引数２ ：開始列インデックス
'* 引数３ ：終了列インデックス
'*
'*************************************************************
Public Function fMaxLastRowIndex(sht As Worksheet, startColumnIndex As Integer, endColumnIndex As Integer) As Long
If (startColumnIndex > endColumnIndex) Then
Err.Raise 1010, , "fMaxLastRowIndex:arg2 >= arg1 でない"
End If
Dim i As Integer
Dim test As Long
For i = startColumnIndex To endColumnIndex
test = fLastRowIndex(sht, i)
If (fMaxLastRowIndex < test) Then
fMaxLastRowIndex = test
End If
Next i
End Function
''配列系↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓
'*************************************************************
'*
'* １次元の配列をソート(昇順)したものを返す。
'*
'*************************************************************
Public Function fSorted_Array_1_Dimension(arrSortTarget As Variant) As Variant
Dim nowSheet As String
Dim length As Integer
Dim res() As Variant
Dim shtWork As Worksheet
Dim i As Integer
nowSheet = ActiveSheet.name
length = UBound(arrSortTarget)
ReDim res(length)
Set shtWork = fSheetAdded("配列ソート作業用")
With shtWork
For i = 1 To length
.Cells(i, 1) = arrSortTarget(i)
Next i
.Range(shtWork.Cells(1, 1), shtWork.Cells(length, 1)).Sort Key1:=shtWork.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
For i = 1 To length
res(i) = .Cells(i, 1)
Next i
End With
fSorted_Array_1_Dimension = res
Worksheets(nowSheet).Activate
Call deleteSheet(shtWork)
End Function
'*************************************************************
'*
'* 二つの配列が等しければTRUEを返す。
'* (1)長さが等しい。
'* (2)同じインデックスに入っている値が全て等しい。
'*
'*************************************************************
Public Function fEqualArrayIs(array1 As Variant, array2 As Variant) As Boolean
fEqualArrayIs = True
Dim len1 As Integer
Dim len2 As Integer
len1 = UBound(array1)
len2 = UBound(array2)
If Not (len1 = len2) Then
fEqualArrayIs = False
Exit Function
End If
Dim i As Integer
For i = 1 To len1
If Not (array1(i) = array2(i)) Then
fEqualArrayIs = False
Exit Function
End If
Next i
End Function
'*************************************************************
'*
'* Collection → Array 数値を昇順ソートして移し変える。
'*
'*************************************************************
Public Function fIntArr_Collection2Array(cllc As Collection) As Variant
Dim i As Integer
Dim res() As Integer
ReDim res(cllc.Count)
For i = 1 To cllc.Count
res(i) = cllc.Item(i).column
Next i
fIntArr_Collection2Array = fSorted_Array_1_Dimension(res)
End Function
'*************************************************************
'*
'* 配列中に同じ数値があればTRUEを返す。
'*
'*************************************************************
Public Function fArrayContainsIntegerIs(test As Integer, array1 As Variant) As Boolean
fArrayContainsIntegerIs = False
Dim len1 As Integer
len1 = UBound(array1)
Dim i As Integer
For i = 1 To len1
If (test = array1(i)) Then
fArrayContainsIntegerIs = True
Exit Function
End If
Next i
End Function
'*************************************************************
'*
'* 配列中に同じ文字列があればTRUEを返す。
'*
'*************************************************************
Public Function fArrayContainsStringIs(test As String, array1 As Variant) As Boolean
fArrayContainsStringIs = False
Dim len1 As Integer
len1 = UBound(array1)
Dim i As Integer
For i = 1 To len1
If (StrComp(test, array1(i), vbBinaryCompare) = 0) Then
fArrayContainsStringIs = True
Exit Function
End If
Next i
End Function
'*************************************************************
'*
'* 開始数値から終了数値までデルタ分ずつ増える配列を返す。
'*
'* arg1 : 開始数値
'* arg2 : 終了数値
'* arg3 : 増分値
'*
'* ex) fArrMapInt(-3, 10, 2) → (-3, -1, 1, 3, 5, 7, 9)
'* ex) fArrMapInt(3, 12, 2) → (3, 5, 7, 9, 11)
'*
'*************************************************************
Public Function fArrMapInt(start As Integer, en As Integer, delta As Integer) As Variant
If (en < start) Then
Err.Raise 1010, , "fArrMapInt:arg2 >= arg1 でない"
End If
Dim res() As Variant
ReDim res(WorksheetFunction.Floor((en - start) / delta + 1, 1))
Dim val As Integer
val = start
Dim idx As Integer
idx = 1
Do Until idx > UBound(res)
res(idx) = val
val = val + delta
idx = idx + 1
Loop
fArrMapInt = res
End Function
'*************************************************************
'*
'* 指定された範囲の値を順に配列につめて返す。
'*
'*************************************************************
Public Function fArrFrom(rng As Range) As Variant
Dim res() As Variant
Dim v As Range
Dim i As Long
With rng
ReDim res(.Rows.Count * .Columns.Count)
i = 1
For Each v In rng
res(i) = v.Value
i = i + 1
Next
End With
fArrFrom = res
End Function
''シート系↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓
'*************************************************************
'*
'* 選択されているシートの枚数が引数と一致していたらTRUEを返す。
'*
'*************************************************************
Public Function fSelectedSheetCountIs(test As Integer) As Boolean
fSelectedSheetCountIs = False
If (ActiveWindow.SelectedSheets.Count = test) Then
fSelectedSheetCountIs = True
End If
End Function
'*************************************************************
'*
'* 指定されたシートを削除する。
'*
'*************************************************************
Public Sub deleteSheet(sht As Worksheet)
Application.DisplayAlerts = False
sht.Delete
Set sht = Nothing
Application.DisplayAlerts = True
End Sub
'*************************************************************
'*
'* 指定された名前を持つシートを最後尾に追加し、Worksheetオブジェクトを返す。
'*
'*************************************************************
Public Function fSheetAdded(shtName As String) As Worksheet
Worksheets.Add After:=Worksheets(Sheets.Count), Count:=1
Worksheets(Sheets.Count).name = shtName
Set fSheetAdded = Worksheets(shtName)
End Function
'*************************************************************
'*
'* シートを指定されたファイルに保存する。
'*
'* arg1 : Sheets
'* arg2 : ファイル名を含んだパス
'*
'*************************************************************
Public Sub saveSheets2NewBook(shts As Sheets, path As String)
Dim bkWork As Workbook 'シートのコピー先ブック
Dim oldSheetsCount As Integer 'シートのコピー先ブックの初期シート枚数
Set bkWork = Workbooks.Add
oldSheetsCount = bkWork.Worksheets.Count
Dim shtWork As Worksheet
For Each shtWork In bkWork.Sheets
If (fExistSheetName(shtWork.name, shts)) Then
shtWork.name = shtWork.name & "_rm"
End If
Set shtWork = Nothing
Next
shts.Copy After:=bkWork.Sheets(oldSheetsCount)
Dim i As Integer
For i = oldSheetsCount To 1 Step -1
Call deleteSheet(bkWork.Worksheets(i))
Next
On Error Resume Next
bkWork.SaveAs fileName:=path
bkWork.Close False
Set bkWork = Nothing
End Sub
'*************************************************************
'*
'* 文字列がすでにシート名に使われているか調べる。
'*
'* arg1 : この文字列がすでに使われているか。
'* arg2 : このSheetsの中で。
'*
'*************************************************************
Public Function fExistSheetName(test As String, shts As Sheets) As Boolean
fExistSheetName = False
Dim sht As Worksheet
For Each sht In shts
If (StrComp(test, sht.name, vbBinaryCompare) = 0) Then
fExistSheetName = True
Exit Function
End If
Next
End Function
''Range系↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓
'*************************************************************
'*
'* 列インデックスが詰まった配列を受け取り、指定された範囲をソート（昇順）する。
'* 空白セルは最小値（-999999)として扱われ最上位にくる。
'* .Selectを使ってるので、Activeシートが対象。
'* （rngTargetにSomeSheet.Range("A1:B2")とかって指定しても、SomeSheetがActivateになっていないとエラーになる）
'* 配列の第１要素が最優先されるキー、第２要素が２番目に優先されるキー、以下同様。
'*
'*************************************************************
Public Function mySort(rngTarget As Range, arrColumnIndexes As Variant) As Boolean
Dim i As Integer
Dim keyRange As Range
rngTarget.Select
Selection.Replace What:=Empty, Replacement:="-999999"
For i = UBound(arrColumnIndexes) To 1 Step -1
Set keyRange = Cells(ActiveCell.row, arrColumnIndexes(i))
Selection.Sort Key1:=keyRange, Order1:=xlAscending, Header:=xlNo, MatchCase:=True
Next i
Selection.Replace What:="-999999", Replacement:=Empty
Set keyRange = Nothing
End Function
'*************************************************************
'*
'* 指定されたRangeの重複のない行インデックス配列を返す。
'*
'*************************************************************
Public Function fRowIndexesIn(rng As Range) As Variant
Dim res() As Long
Dim test As Variant
Dim i As Long
i = 1
For Each test In rng
If (i = 1) Then
ReDim Preserve res(i)
res(i) = test.row
i = i + 1
Else
If Not (fArrayContainsIntegerIs(test.row, res)) Then
ReDim Preserve res(i)
res(i) = test.row
i = i + 1
End If
End If
Next
fRowIndexesIn = fSorted_Array_1_Dimension(res)
End Function
''ダイアログ系↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓
'*************************************************************
'*
'* パターンダイアログを表示し選んだColorIndex、Pattern、PatternColorIndexの配列を返す。
'*
'* return : Variant型配列。ダイアログでの選択により以下のようになる。
'* [OK] : Integer型配列 [ColorIndex, Pattern, PatternColorIndex]
'* [キャンセル] : False
'*
'*************************************************************
Public Function fUserSelectInterior_PatternDialog() As Variant
Dim saveColorIndex As Integer
Dim savePattern As Integer
Dim savePatternColorIndex As Integer
With ActiveCell.Interior
saveColorIndex = .ColorIndex
savePattern = .Pattern
savePatternColorIndex = .PatternColorIndex
End With
Dim bl As Boolean
bl = Application.Dialogs(xlDialogPatterns).Show
If (bl) Then
Dim res(3) As Integer
With ActiveCell.Interior
res(1) = .ColorIndex
res(2) = .Pattern
res(3) = .PatternColorIndex
End With
fUserSelectInterior_PatternDialog = res
Else
fUserSelectInterior_PatternDialog = False
Exit Function
End If
With ActiveCell.Interior
.ColorIndex = saveColorIndex
.Pattern = savePattern
.PatternColorIndex = savePatternColorIndex
End With
End Function
''データベース系↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓
'*************************************************************
'*
'* オープン済コネクションを返す。
'* arg1 ： プロバイダ文字列
'* arg2 ： データソース文字列
'* arg3 ： ユーザID文字列
'* arg4 ： パスワード文字列
'*
'*************************************************************
Public Function fDBConnection(strProvider As String _
, strDataSource As String _
, strUser As String _
, strPassword As String) As ADODB.Connection
Dim conn As New Connection
With conn
.ConnectionString = "Provider=" & strProvider & ";Data Source=" & strDataSource & ";User ID=" & strUser & ";Password=" & strPassword & ";"
.Open
.CursorLocation = adUseClient
End With
Set fDBConnection = conn
Set conn = Nothing
Exit Function
End Function
'*************************************************************
'*
'* SQLを実行する。
'* 更新系SQLはNothingを返す。
'*
'* arg1 : オープン済みコネクション
'* arg2 : SQL文字列
'* arg3 : 更新件数を受け取る変数
'*
'*************************************************************
Public Function fExecuteSql(conn As ADODB.Connection, strSql As String, Optional ByRef chgCount As Long = 0) As ADODB.Recordset
Dim rs As New ADODB.Recordset
chgCount = 0
Set rs = conn.Execute(strSql, chgCount)
If (rs.State = adStateClosed) Then
Set fExecuteSql = Nothing
Else
Set fExecuteSql = rs
End If
Set rs = Nothing
End Function
'*************************************************************
'*
'* テーブル名一覧配列を返す。
'* arg1 : オープン済コネクション
'* arg2 : スキーマ名
'*
'*************************************************************
Public Function fTableNames(conn As ADODB.Connection, strSchema As String)
Dim res() As Variant
Dim rs As ADODB.Recordset
Set rs = conn.OpenSchema(adSchemaTables, Array(Empty, strSchema))
rs.Sort = "TABLE_NAME ASC" 'テーブルもビューも区別せず昇順に並び替える。
Dim i As Integer
i = 1
Do Until rs.EOF
ReDim Preserve res(i)
res(i) = rs("TABLE_NAME")
rs.MoveNext
i = i + 1
Loop
fTableNames = res
rs.Close
Set rs = Nothing
End Function
'*************************************************************
'*
'* 指定したテーブルについての列名配列を返す。
'*
'* arg1 : オープン済みコネクション
'* arg2 : テーブル名
'* arg3 : SchemeEnum型変数
'* adSchemaColumns : テーブルのすべての列について。
'* adSchemaPrimaryKeys : テーブルの主キー列について。
'*
'*************************************************************
Public Function fArrTableColumnName(conn As ADODB.Connection _
, tableName As String _
, se As SchemaEnum) As Variant
Dim arrCriterias() As Variant '制約配列
arrCriterias = Array(Empty, Empty, tableName)
Dim rs As ADODB.Recordset
Set rs = conn.OpenSchema(se, arrCriterias)
Dim res() As Variant
Dim i As Integer
i = 1
Do Until rs.EOF
ReDim Preserve res(i)
res(i) = rs("COLUMN_NAME")
rs.MoveNext
i = i + 1
Loop
fArrTableColumnName = res
rs.Close
Set rs = Nothing
End Function
'*************************************************************
'*
'* レコードセットから列属性配列を返す。
'*
'* arg1 : レコードセット
'* arg2 : "COLUMN_NAME" : 列名
'* "DEFINED_SIZE" : 桁数（文字）
'* "NUMERIC_SCALE" : 桁数（数値）
'* "PRECISION" : 小数点以下桁数（数値）
'*
'*************************************************************
Public Function fArrColumnAttribute(rs As ADODB.Recordset, strAttribute As String) As Variant
Dim res() As Variant
Dim flds As ADODB.Fields
Dim f As ADODB.field
Set flds = rs.Fields
Dim col As Integer
col = 1
For Each f In flds
ReDim Preserve res(col)
Select Case strAttribute
Case "COLUMN_NAME": res(col) = f.name
Case "COLUMN_TYPE": res(col) = f.Type
Case "DEFINED_SIZE": res(col) = f.DefinedSize
Case "NUMERIC_SCALE": res(col) = f.NumericScale
Case "PRECISION": res(col) = f.Precision
End Select
col = col + 1
Next
fArrColumnAttribute = res
Set f = Nothing
Set flds = Nothing
End Function
'*************************************************************
'*
'* レコードセットから列のデータ型(DataTypeEnum型)配列を返す。
'*
'* arg1 : レコードセット
'*
'*************************************************************
Public Function fArrColumnType(rs As ADODB.Recordset) As Variant
Dim res() As ADODB.DataTypeEnum
Dim flds As ADODB.Fields
Dim f As ADODB.field
Set flds = rs.Fields
Dim col As Integer
col = 1
For Each f In flds
ReDim Preserve res(col)
res(col) = f.Type
col = col + 1
Next
fArrColumnType = res
Set f = Nothing
Set flds = Nothing
End Function
'*************************************************************
'*
'* DataTypeEnum（意味わかんない数値）を分かりやすくした文字列を返す。
'*
'* arg1 : DataTypeEnum
'*
'*************************************************************
Public Function fTranslate_TableColumnType(test As DataTypeEnum) As String
fTranslate_TableColumnType = ""
Select Case test
Case 129: fTranslate_TableColumnType = "CHAR" 'adchar
Case 131, 139: fTranslate_TableColumnType = "NUMBER" 'adNumeric,adVarNumeric
Case 135: fTranslate_TableColumnType = "DATE" 'adDBTimeStamp
Case 200: fTranslate_TableColumnType = "VARCHAR2" 'adVarChar
Case Else: fTranslate_TableColumnType = ""
End Select
End Function
0 件のコメント:
コメントを投稿