Option Explicit
'Analyse
Sub CreateSheets()
Dim ArrPersons() As String
Dim IPerCount As Integer
Dim i As Integer, WsThis As Worksheet
Dim StrSheetName As String
Dim IsChgSet As Boolean
Dim Wstemp As Worksheet
Dim WsList As Worksheet
Application.ScreenUpdating = False
'On Error Resume Next
'Debug.Print ThisWorkbook.VBProject.Protection
Dim ObjComboBoxYear As OLEObject
Dim ObjComboBoxMOnth As OLEObject
Set WsList = Workbooks("CD.xls").Worksheets("HolidaySheet")
IPerCount = GetPersonsFromOutSheet(ArrPersons)
'MsgBox GArrStrOpenFileHead(1, 1) & 1
If IPerCount > 0 Then
For i = 0 To IPerCount - 1
StrSheetName = "担当者" & ArrPersons(i) & "予定分析"
If ChkHaveSheet(StrSheetName) Then
'Application.DisplayAlerts = False
Worksheets(StrSheetName).Delete
'Application.DisplayAlerts = True
End If
Worksheets("planasheet").Copy after:=Worksheets(3)
Set Wstemp = Worksheets(4)
With Wstemp
.Name = StrSheetName
Set ObjComboBoxYear = .OLEObjects("CmbYear")
Set ObjComboBoxMOnth = .OLEObjects("CmbMonth")
With WsList
ObjComboBoxYear.Object.List = .Range("C2:C" & .Range("C1").End(xlDown).Row).Value
ObjComboBoxMOnth.Object.List = .Range("D2:D" & .Range("D1").End(xlDown).Row).Value
End With
End With
Set WsThis = Worksheets(StrSheetName)
If Not WriterConTents(WsThis, ArrPersons(i)) Then
MsgBox "error"
Exit Sub
End If
Next i
End If
End Sub
Function WriterConTents(WsThis As Worksheet, ArrPersons As String) As Boolean
Dim RngTemp As Range
Dim i As Long, j As Long
WriterConTents = False
With WsThis
.Cells(2, 2).Interior.color = 255
.Cells(2, 3).Value = " 1日当りの作業時間が7Hを越える場合と遅れが生ずる場合には警告を表示する"
End With
With WsThis
Workbooks("CD.xls").Worksheets("担当者A予定分析1").Range("B5:O11").Copy .Range("B5")
End With
Dim IstartLine As Long
IstartLine = GetStartLine(WsThis)
With WsThis
'Call AddComboBoxYear(WsThis, .Cells(IstartLine, 2))
Cells(IstartLine, 3) = "年"
'Call AddComboBoxMonth(WsThis, .Cells(IstartLine, 4))
Cells(IstartLine, 5) = "月"
'Call AddButton(WsThis, .Cells(IstartLine, 6))
End With
WriterConTents = True
End Function
Function GetStartLine(WsThis As Worksheet) As Long
With WsThis
GetStartLine = Cells(.Rows.Count, 2).End(xlUp).Row + 2
End With
End Function
Sub AddClickCode(WsThis As Worksheet, StrName As String)
Dim StrCodes As String
Dim OBjVba As Object
Dim ObjShtModule As Object
StrCodes = vbCrLf & "Private Sub " & StrName & "_Click()" & vbCrLf & "call " & "showAAA" & vbCrLf & "End Sub"
Set OBjVba = ActiveWorkbook.VBProject
Set ObjShtModule = OBjVba.VBComponents(WsThis.CodeName).CodeModule
With ObjShtModule
.InsertLines .countoflines + 1, StrCodes
End With
End Sub
Sub AddComboBoxYear(WsThis As Worksheet, ByVal RngTarget As Range)
Dim ObjComboBox As OLEObject
Dim WsList As Worksheet
'Set RngTarget = WsThis.Cells(1, 1)
Set ObjComboBox = WsThis.OLEObjects.Add(ClassType:="Forms.combobox.1", Link:=False, DisplayAsIcon:=False, Left:=RngTarget.Left, Top:=RngTarget.Top, Width:=RngTarget.Width, Height:=RngTarget.Height + 4)
Set WsList = Workbooks("CD.xls").Worksheets("HolidaySheet")
ObjComboBox.Visible = True
ObjComboBox.Name = "CmbYear"
With WsList
ObjComboBox.Object.List = .Range("C2:C" & .Range("C1").End(xlDown).Row).Value
End With
Randomize
ObjComboBox.Object.ListIndex = Int(Rnd * 7)
End Sub
Sub AddComboBoxMonth(WsThis As Worksheet, ByVal RngTarget As Range)
Dim ObjComboBox As OLEObject
Dim WsList As Worksheet
'Set RngTarget = WsThis.Cells(1, 3)
Set ObjComboBox = WsThis.OLEObjects.Add(ClassType:="Forms.combobox.1", Link:=False, DisplayAsIcon:=False, Left:=RngTarget.Left - 10, Top:=RngTarget.Top, Width:=RngTarget.Width, Height:=RngTarget.Height + 4)
Set WsList = Workbooks("CD.xls").Worksheets("HolidaySheet")
ObjComboBox.Visible = True
ObjComboBox.Name = "CmbMonth"
With WsList
ObjComboBox.Object.List = .Range("D2:D" & .Range("D1").End(xlDown).Row).Value
End With
Randomize
ObjComboBox.Object.ListIndex = Int(Rnd * 7)
End Sub
Sub AddButton(WsThis As Worksheet, ByVal RngTarget As Range)
Dim ObjCommandButton As OLEObject
'Set RngTarget = WsThis.Cells(1, 5)
Set ObjCommandButton = WsThis.OLEObjects.Add(ClassType:="Forms.commandbutton.1", Link:=False, DisplayAsIcon:=False, Left:=RngTarget.Left - 10, Top:=RngTarget.Top - 3, Width:=RngTarget.Width + 4, Height:=RngTarget.Height + 10)
ObjCommandButton.Visible = True
ObjCommandButton.Name = "CmdSetDate"
ObjCommandButton.Object.Caption = "設定"
End Sub
Sub showAAA()
MsgBox ActiveSheet.Cells(6, 6)
End Sub