1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163
| Option Explicit
Public Const COLONNE_LIBELLE = 1
Public Const LIGNE_EN_TETE = 1
Public gWSManageSheet As Worksheet
Public gWSMonth As Worksheet
Public Function manageRange(ByVal p_range As Range) As Range
Dim intLigne As Integer
Dim intColonne As Integer
Dim strNameTraitement As String
Dim intDay As Integer
Dim range_ As Range
For intLigne = 2 To p_range.Rows.Count
strNameTraitement = p_range.Cells(intLigne, COLONNE_LIBELLE)
For intColonne = 2 To p_range.Columns.Count
If p_range(intLigne, intColonne) <> vbNullString Then
Set range_ = p_range(LIGNE_EN_TETE, intColonne)
'intDay = Left(range_.Value, 2)
intDay = Left(Format(range_.Value, "dd/mm/yyyy"), 2)
If Not copyToMonthSheet(intDay, strNameTraitement) Then
MsgBox "erreur lors du traitement de la plage : " & vbCrLf & CStr(p_range.Address), vbOKOnly
Exit Function
End If
End If
Next
Next
End Function
Public Function copyToMonthSheet(ByVal pDay As Integer, ByVal pTraitement As String) As Boolean
Dim intTraitementRow As Integer
Dim i As Integer
intTraitementRow = 0
copyToMonthSheet = True
For i = 1 To lastRow(gWSMonth)
If LCase(gWSMonth.Range("A" & i)) = LCase(pTraitement) Then
intTraitementRow = i
Exit For
End If
Next
If intTraitementRow = 0 Then
copyToMonthSheet = False
Exit Function
End If
With gWSMonth.Cells(intTraitementRow, pDay + 1)
.Value = "X"
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End Function
Public Function isInCollection(ByVal pCol As Collection, pStr As String) As Boolean
Dim i As Integer
isInCollection = False
If pCol.Count < 1 Then Exit Function
For i = 1 To pCol.Count
If Trim$(pCol(i)) = Trim$(pStr) Then
isInCollection = True
Exit For
End If
Next
End Function
Public Sub searchInCollectionAndDestroy(ByVal pCol As Collection, pStr As String)
Dim i As Integer
If pCol.Count < 1 Then Exit Sub
For i = 1 To pCol.Count
If pCol(i) = Trim$(pStr) Then pCol.Remove (i)
Exit For
Next
End Sub
Public Sub manageSheet(ByVal pStrName As String)
Dim sheet_ As Worksheet
Dim blnExist As Boolean
For Each sheet_ In ThisWorkbook.Sheets
If sheet_.Name = pStrName Then
blnExist = True
If MsgBox("Feuille existante, écraser ?", vbYesNo + vbQuestion) = vbYes Then
sheet_.Cells.Clear
Set gWSMonth = sheet_
End If
End If
Next
If Not blnExist Then
Set gWSMonth = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
gWSMonth.Name = pStrName
End If
End Sub
Public Sub makeHeadLine()
Dim col_ As Collection
Dim i As Integer
Dim firstDay As Integer
Dim lastDay As Integer
Dim strMonth As String
firstDay = CInt(Format(DateSerial(Year(Now), Month(Now), 1), "d"))
lastDay = CInt(Format(DateSerial(Year(Now), Month(Now) + 1, 0), "d"))
strMonth = Format(Now, "mmmm")
Set col_ = New Collection
Set gWSManageSheet = ThisWorkbook.Sheets("Planning")
Call manageSheet(strMonth)
For i = 1 To lastRow(gWSManageSheet)
If Not isInCollection(col_, gWSManageSheet.Range("A" & i)) Then
col_.Add Trim$(gWSManageSheet.Range("A" & i).Text)
End If
Next
Call searchInCollectionAndDestroy(col_, "Traitement ITINP")
gWSMonth.Range("A1") = Trim$("Traitement ITINP")
For i = firstDay To lastDay
gWSMonth.Cells(LIGNE_EN_TETE, i + 1) = DateSerial(Year(Now), Month(Now), i)
gWSMonth.Cells(LIGNE_EN_TETE, i + 1).NumberFormat = "dd/mm"
Next
For i = 1 To col_.Count
gWSMonth.Range("A" & i + 1) = col_(i)
Next
End Sub
Public Sub main()
Dim lIntIndex1 As Integer
Dim lIntIndex2 As Integer
Dim i As Integer
Dim range_ As Range
Dim cell1_ As Range
Dim cell2_ As Range
Set gWSManageSheet = ThisWorkbook.Sheets("Planning")
i = 1
lIntIndex1 = 1
lIntIndex2 = 1
Call makeHeadLine
For i = 2 To lastRow(gWSManageSheet) + 1
If LCase(gWSManageSheet.Range("A" & i).Text) <> "traitement itinp" And LCase(gWSManageSheet.Range("A" & i).Text <> vbNullString) Then
lIntIndex2 = i
Else
Set cell1_ = gWSManageSheet.Cells(lIntIndex1, COLONNE_LIBELLE)
Set cell2_ = gWSManageSheet.Cells(lIntIndex2, lastColumn(gWSManageSheet, lIntIndex1))
Set range_ = gWSManageSheet.Range(cell1_, cell2_)
Call manageRange(range_)
lIntIndex1 = i
lIntIndex2 = i
End If
Next
End Sub
Public Function lastRow(ByVal pws As Worksheet) As Integer
lastRow = pws.UsedRange.SpecialCells(xlCellTypeLastCell).Row
End Function
Public Function lastColumn(ByVal pws As Worksheet, ByVal pRow As Integer) As Integer
lastColumn = pws.Cells(pRow, 128).End(xlToLeft).Column
End Function |
Partager