Sub transferer()
Application.ScreenUpdating = False
Dim TabBase1() As Variant 'tablo de données de Base Jeudi au lundi
Dim TabBase2() As Variant ' tablo de données de Base Dimanche
Dim TabFinal() As Variant 'tablo de données finales à redisposer
Set WsBase1 = Sheets("Base Jeudi au lundi")
Set WsBase2 = Sheets("Base Dimanche")
'on récupère les données SANS entetes
With WsBase1
TabBase1 = .UsedRange.Offset(1, 0).Value
End With
With WsBase2
TabBase2 = .UsedRange.Offset(1, 0).Value
End With
'sur le tablo 1
For i = LBound(TabBase1, 1) To UBound(TabBase1, 1) 'pour chaque ligne
If UCase(TabBase1(i, 1)) = "X" And TabBase1(i, 4) <> "" Then 'si on est sur un début de bloc à garder
TabBase1(i + 1, 1) = TabBase1(i, 1) 'on recopie le X à la ligne du dessous
TabBase1(i + 1, 2) = TabBase1(i, 2) 'on recopie le Nom à la ligne du dessous
TabBase1(i + 1, 3) = TabBase1(i, 3) 'on recopie le tel à la ligne du dessous
Select Case TabBase1(i, 4) ' on remplace le jour par son numéro
Case "Lundi"
TabBase1(i, 4) = 1
Case "Mardi"
TabBase1(i, 4) = 2
Case "Mercredi"
TabBase1(i, 4) = 3
Case "Jeudi"
TabBase1(i, 4) = 4
Case "Vendredi"
TabBase1(i, 4) = 5
Case "Samedi"
TabBase1(i, 4) = 6
Case "Dimanche"
TabBase1(i, 4) = 7
End Select
Else 'sinon on efface la ligne complète
For j = LBound(TabBase1, 2) To UBound(TabBase1, 2)
TabBase1(i, j) = ""
Next j
End If
Next i
'on fait la meme chose sur le tablo2
For i = LBound(TabBase2, 1) To UBound(TabBase2, 1)
If UCase(TabBase2(i, 1)) = "X" And TabBase2(i, 4) <> "" Then
TabBase2(i + 1, 1) = TabBase2(i, 1)
TabBase2(i + 1, 2) = TabBase2(i, 2)
TabBase2(i + 1, 3) = TabBase2(i, 3)
Select Case TabBase2(i, 4)
Case "Lundi"
TabBase2(i, 4) = 1
Case "Mardi"
TabBase2(i, 4) = 2
Case "Mercredi"
TabBase2(i, 4) = 3
Case "Jeudi"
TabBase2(i, 4) = 4
Case "Vendredi"
TabBase2(i, 4) = 5
Case "Samedi"
TabBase2(i, 4) = 6
Case "Dimanche"
TabBase2(i, 4) = 7
End Select
Else
For j = LBound(TabBase2, 2) To UBound(TabBase2, 2)
TabBase2(i, j) = ""
Next j
End If
Next i
'on colle les deux tableaux l'un en dessous de l'autre dans la feuille test
With Sheets("Test")
.UsedRange.Clear
.Range("A1").Resize(UBound(TabBase1, 1), UBound(TabBase1, 2)) = TabBase1
fin = .UsedRange.Rows.Count
.Range("A" & fin + 1).Resize(UBound(TabBase2, 1), UBound(TabBase2, 2)) = TabBase2
Set zone = .UsedRange
'on applique un tri sur les colonnnes B et D==> les lignes vides se retrouvent en bas
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=zone.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=zone.Columns(4), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Test").Sort
.SetRange zone
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
.Activate
.Range("A1").Select
TabFinal = .UsedRange.Value 'on met tout le tableau dans un tablo vba
End With
With Sheets("Final") 'dans la feuille final
.Activate 'on l'affiche
.UsedRange.Offset(1, 0).EntireRow.Delete 'on la vide SAUF la ligne des jours
For i = LBound(TabFinal, 1) To UBound(TabFinal, 1) 'pour chaque ligne
LastLine = .UsedRange.Rows.Count + 2 'on récupère le numéro de la ligne sur laquelle on va écrire
If i = 1 Then 'cas particulier de la première ligne de données
.Range("A" & LastLine) = TabFinal(i, 2) ' on colle le nom
.Range("B" & LastLine) = TabFinal(i, 3) 'on colle le tél
ElseIf TabFinal(i, 2) <> TabFinal(i - 1, 2) Then 'si on est sur un nouveau nom
.Range("A" & LastLine) = TabFinal(i, 2) ' on colle le nom
.Range("B" & LastLine) = TabFinal(i, 3) 'on colle le tél
End If
'on colle l'information = concaténation de l'heure, ville et affectation
'.Cells(LastLine, 2 + TabFinal(i, 4)) = Format(TabFinal(i, 5), "hh:mm:ss") & " " & TabFinal(i, 6) & " " & TabFinal(i, 7)
.Cells(LastLine, 2 + TabFinal(i, 4)) = Format(TabFinal(i, 5), "hh:mm:ss") & Chr(10) & TabFinal(i, 6) & Chr(10) & TabFinal(i, 7)
Next i
End With
Application.ScreenUpdating = True
End Sub
