| |
★不明な点
1、データシートのシート名とListの行位置？
→ シート名を"Sheet1"、「列A：氏名」をA1のセル位置とする
2、「シート名：一覧」の表の位置？
→ 列見出し「氏名」のセル位置をA1とする
3、データシートの整列の有無？
→ マクロ中で氏名昇順の課題番号昇順の項目昇順の作業日付昇順に整列させる
4、データシートの作業日付、「シート名：一覧」の日付の型？
→ 共にシリアル値とし、データシートは"yyyy/m/d"、「シート名：一覧」はd"日"とする
5、「シート名：一覧」の各項目が予め書かれているか？
→ マクロ実行時に各項目も作成する
6、「シート名：一覧」のカレンダが予め書かれているか？
→ マクロ実行時にカレンダも作成する
7、カレンダの日付を連続とするか？、必要な日付だけ表示するか？
→ データシートの日付のMin月の１日〜Max月の末日まで連続して表示
8、使用方法として、マクロ実行時に「シート名：一覧」へ追加していくのか？、常に新規に作り直すのか？
→ マクロ実行時に、常に新規に作り直す
上記で位置関係を除き、如何するに因ってコードが大幅に変わると思います
上記の不明点を矢印以降で補った例を以下にUpします
Option Explicit
Public Sub Sample()
'データ列数を設定
Const clngColumns As Long = 6
'日付の先頭列位置(「一覧」の先頭A列から数えて何番目）
Const clngDayTop As Long = 5
Dim i As Long
Dim lngRows As Long
Dim rngList As Range
Dim vntData As Variant
Dim rngResult As Range
Dim vntResult As Variant
Dim vntDayMax As Variant
Dim vntDayMin As Variant
Dim vntComp As Variant
Dim lngRow As Long
Dim strProm As String
'データListの左上隅セル位置を基準として設定(列見出しの最左セル位置)
Set rngList = Worksheets("Sheet1").Cells(1, "A")
'一覧の左上隅セル位置を基準として設定(列見出しの最左セル位置)
Set rngResult = Worksheets("一覧").Cells(1, "A")
With rngList
'データ行数を取得
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
'データが無い場合
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'データListを"氏名"順の"課題番号"順の"項目"順の"作業日付"順で整列
.Offset(1).Resize(lngRows, clngColumns).Sort _
Key1:=.Offset(, 4), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
.Offset(1).Resize(lngRows, clngColumns).Sort _
Key1:=.Offset, Order1:=xlAscending, _
Key2:=.Offset(, 1), Order2:=xlAscending, _
Key3:=.Offset(, 3), Order3:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'作業日付のMax、Minを取得
With .Offset(1, clngColumns - 2).Resize(lngRows)
vntDayMax = Application.WorksheetFunction.Max(.Resize(lngRows))
vntDayMin = Application.WorksheetFunction.Min(.Resize(lngRows))
End With
End With
'日付先頭日を計算
vntDayMin = CLng(DateSerial(Year(vntDayMin), Month(vntDayMin), 1))
'日数を計算
vntDayMax = CLng(DateSerial(Year(vntDayMax), Month(vntDayMax) + 1, 0)) _
- vntDayMin + 1
'結果配列を確保
ReDim vntResult(1 To 1, 1 To vntDayMax + clngDayTop - 1)
'先頭項目を代入
For i = 1 To clngDayTop - 1
vntResult(1, i) = Choose(i, "氏名", "課題番号", "件名", "項目")
Next i
'日付を代入
For i = 0 To vntDayMax - 1
vntResult(1, clngDayTop + i) = vntDayMin + i
Next i
'画面更新を停止
Application.ScreenUpdating = False
'一覧シートの初期化
With rngResult
'シートをクリア
.Parent.Cells.ClearContents
'日付のセル範囲の書式設定
.Offset(, clngDayTop - 1).Resize(, _
vntDayMax).NumberFormatLocal = "d""日"""
'項目、日付を出力
.Resize(, UBound(vntResult, 2)).Value = vntResult
End With
'結果配列を再確保
ReDim vntResult(1 To 1, 1 To vntDayMax + clngDayTop - 1)
'データシートから先頭１行を配列に取得
vntData = rngList.Offset(1).Resize(, clngColumns).Value
'各項目を結果配列に転記
For i = 1 To clngDayTop - 1
vntResult(1, i) = vntData(1, i)
Next i
'作業時間を作業日付位置に代入
vntResult(1, vntData(1, clngDayTop) - vntDayMin + clngDayTop) _
= vntData(1, clngDayTop + 1)
ReDim Preserve vntData(1 To 1, 1 To clngDayTop - 1)
'比較項目を作成
vntComp = vntData
'２行目から最終行まで繰り返し
For i = 2 To lngRows + 1
'データ1行を配列に取得
vntData = rngList.Offset(i).Resize(, clngColumns).Value
'もし、"氏名"、 "課題番号"、 "件名"、 "項目"の１つでも違った場合
If Not DataCheck(vntData, vntComp) Then
'出力行を更新
lngRow = lngRow + 1
'結果配列を出力
rngResult.Offset(lngRow).Resize(, _
UBound(vntResult, 2)).Value = vntResult
'出力用配列を初期化
IinitializeArray vntData, vntResult, vntComp
End If
'作業時間を作業日付位置に代入
If vntData(1, 1) <> "" Then
vntResult(1, vntData(1, clngDayTop) - vntDayMin + clngDayTop) _
= vntData(1, clngDayTop + 1)
End If
Next i
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function DataCheck(vntData As Variant, _
vntComp As Variant) As Boolean
' "氏名", "課題番号", "件名", "項目"が前と変わった場合
' Falseを返す
Dim i As Long
DataCheck = True
For i = 1 To UBound(vntComp, 2)
If vntData(1, i) <> vntComp(1, i) Then
DataCheck = False
Exit Function
End If
Next i
End Function
Private Sub IinitializeArray(vntData As Variant, _
vntResult As Variant, _
vntComp As Variant)
' 結果出力用配列と比較用配列の初期化
Dim i As Long
For i = UBound(vntComp, 2) + 1 To UBound(vntResult, 2)
vntResult(1, i) = Empty
Next i
For i = 1 To UBound(vntComp, 2)
If vntData(1, i) = vntComp(1, i) Then
vntResult(1, i) = Empty
Else
vntResult(1, i) = vntData(1, i)
vntComp(1, i) = vntData(1, i)
End If
Next i
End Sub
|
|
Hirofumi
- 05/12/30(金) 16:57 -
