|
Private Function dfmysort(ByRef vntData As Variant, _
ByRef lngRow As Long) As Boolean
'
' 作 者(Writer) : lotusnut.net
' 目 的(Aim) : 4月〜3月のデータを並び替える mysort版
' 履 歴(History): Ver 0.0.0 2014 Original
’ 列の例 ： A列なし B列(月) C列(日) D列(適要) E列(節) F列(数量)
G列(単価) H列(収入) I列(支出) J列(差引残)は標準関数
'
On Error GoTo ErrTrap
'変数の宣言
Dim tmpData As Variant
Dim vntDay As Variant
Dim rng As Range
Dim Allrng As Range
Dim vntCol As Variant
Dim lngCount As Long
Dim intCount As Integer
Dim vntMon As Variant
Dim lngMax As Long
Dim i As Integer
Dim l As Long
Dim x As Integer
'戻り値の初期化
dfmysort = False
'インスタンス（余裕を持った範囲）
Set Allrng = Range("D4:D1000")
'/* 処理の実行 */
'列は配列でなく cell(lngCol,lngRow)で処理してもよい
vntCol = Array("B", "C", "D", "E", "F", "G", "H", "I")
'0は空行＝最下行に、日の空は最上位
vntMon = Array(4, 5, 6, 7, 8, 9, 10, 11, 12, 1, 2, 3, 0)
'データ量（添え字の決定）
lngMax = dfVlCount(Allrng) - 1
'配列の添え字
ReDim tmpData(lngMax, 7)
ReDim vntDay(lngMax, 7)
ReDim vntData(lngMax, 7)
'データ数の検証
For Each rng In Allrng
If rng.Value <> "" Then
For intCount = 0 To 7
tmpData(lngCount, intCount) = Range(vntCol(intCount) & rng.Row)
Next intCount
lngCount = lngCount + 1
End If
Next
'一旦日付順に並び替える
For intCount = 0 To 31
For lngCount = 0 To lngMax
If tmpData(lngCount, 1) = intCount Then
For i = 0 To 7
vntDay(l, i) = tmpData(lngCount, i)
Next i
l = l + 1
End If
Next lngCount
Next intCount
'年度における月（4月に始まり3月に終了）データを変数に代入
l = 0
For intCount = 0 To 12
For lngCount = 0 To lngMax
If vntDay(lngCount, 0) = vntMon(intCount) Then
For i = 0 To 7
vntData(l, i) = vntDay(lngCount, i)
Next i
l = l + 1
End If
Next lngCount
Next intCount
'インスタンス開放
Set Allrng = Nothing
'正常な戻り値
lngRow = lngMax
dfmysort = True
Exit Function
'ｴﾗｰﾄﾗｯﾌﾟ
ErrTrap:
Debug.Print "dfmysort ｴﾗｰ : " & Err.Description
On Error GoTo 0
End Function
'******************************************************************************************************
次に リスト化するコントロールにデータベースライクなセルの任意のフィールドのデータを取り入れる。
Public Function dfOverListDB(ByRef ctrl As Variant, _
ByRef tagRng As Range) As Boolean
'
' 作 者(Writer) : lotusnut.net
' 目 的(Aim) : * リスト内で重複しない文字列をリスト化
' 入 力(Input) : * ListBoxｺﾝﾄﾛｰﾙ,path,table名,ﾌｨｰﾙﾄﾞ名
' 履 歴(History) : Ver 0.0.0 2003/5/6 Original
'
On Error GoTo ErrTrap
'ﾛｰｶﾙ変数の宣言
Dim Ws As Worksheet
Dim vntData As Variant
Dim rng As Range
Dim tmpArray() As Variant
Dim myArray() As Variant
Dim lngCount As Long
Dim intCount As Integer
'戻り値の初期化
dfOverListDB = False
'引数の検証＆変換
If Not (TypeOf ctrl Is ComboBox) And Not (TypeName(ctrl) = "ListBox") Then
Debug.Print "dfSetListBoxDBｺﾝﾄﾛｰﾙｴﾗｰ"
Exit Function
End If
'インスタンス
Set Ws = tagRng.Worksheet
'***** ﾌﾟﾛｼｰｼﾞｬ処理の実行 *****
'ターゲットデータの数
lngCount = dfDbCount(Ws.Range("A2:A5000"))
'配列の初期化
ReDim tmpArray(lngCount, 1)
lngCount = 0
'該当項目をリスト化
For Each rng In tagRng
vntData = rng.Value
If vntData = "" Then Exit For
'重複リストでない
If Not dfMatchFound(ctrl, vntData) Then
ctrl.AddItem vntData
tmpArray(lngCount, 0) = Ws.Range("A" & rng.Row)
'主力表示は項目の欄
tmpArray(lngCount, 1) = vntData
lngCount = lngCount + 1
End If
Next
'インスタンス
Set Ws = Nothing
'データが無ければ
If lngCount = 0 Then Exit Function
ReDim myArray(lngCount - 1, 1)
'有効なデータのみコピー
For intCount = 0 To lngCount - 1
myArray(intCount, 0) = tmpArray(intCount, 0)
myArray(intCount, 1) = tmpArray(intCount, 1)
Next intCount
'コントロールの初期化
If ctrl.ListCount > 0 Then ctrl.Clear
'コントロールの設定
ctrl.ColumnCount = 2
ctrl.ColumnWidths = 0 'ID番号を非表示
ctrl.BoundColumn = 1 'コントロールの値の規定値＝ID
ctrl.TextColumn = 2 'テキスト表示の規定値
'コントロールに関連付け
ctrl.List() = myArray
'ここまでくれば完全成功
dfOverListDB = True
Exit Function
'ｴﾗｰﾄﾗｯﾌﾟ
ErrTrap:
MsgBox "dfOverListDB ｴﾗｰ : " & Err.Description
On Error GoTo 0
End Function
|
