kabol | Pour les passionnés, je vous donne un bout de code qu'un certain Mercatog m'a gentil fournit sur un autre forum:
Code :
- '---------------------------------------------------------------------------------------
- 'Sub qui permet de copier les données de la feuille SOURCE vers la feuille DESTINATION et reformatage des données suivant les explications fournies
- '//!\\ Adapter dans cette sub les noms des 2 feuilles SOURCE et DESTINATION
- ' Adapter aussi les mots TitreC et vache
- '---------------------------------------------------------------------------------------
- '
- Private Sub FormaterDonnees()
- Dim c As Range, v As Range
- Dim i As Integer
- Dim Tb
- Application.ScreenUpdating = False
- 'On efface le contenu éventuel de la feuille Destination
- Worksheets("DESTINATION" ).UsedRange.Clear
- With Worksheets("SOURCE" )
- 'On recherche la colonne TitreC
- Set c = .UsedRange.Find("TitreC", LookIn:=xlValues, lookat:=xlWhole)
- If Not c Is Nothing Then
- c.CurrentRegion.Copy Worksheets("DESTINATION" ).Range("A1" )
- Set c = Nothing
- End If
- End With
- With Worksheets("DESTINATION" )
- 'Suppression des colonnes D ensuite B
- .Columns(4).Delete
- .Columns(2).Delete
- Set c = .Range("A1" ).CurrentRegion
- 'Suppression des lignes ne contenant pas vache en colonne TitreA (colonne 1)
- Call SupprFiltre(c, 1, "vache" )
- 'Suppression des lignes vides de la colonne TitreC (Colonne 2, qui était colonne 3 avant la suppression de la colonne TitreB)
- Call SupprFiltre(c, 2, "*" )
- 'On éclate les nombres séparés par le point dans les colonnes D,E et F
- For Each v In Intersect(c, .Range("B:B" ))
- Tb = Split(v, "." )
- For i = 0 To UBound(Tb)
- v.Offset(0, i + 2) = Tb(i)
- Next i
- Next v
- Set c = c.Resize(c.Rows.Count, c.Columns.Count + 3)
- 'On tri sur D, puis E enfin F
- c.Sort Key1:=.Range("D1" ), Order1:=xlAscending, Key2:=.Range("E1" ), Order2:=xlAscending, Key3:=.Range("F1" ), Order3:=xlAscending, Header:=xlYes
- 'On insère une ligne entre sections
- Call SepareSections(c)
- 'On supprime les colonnes D,E et F
- .Range("D:F" ).EntireColumn.Delete
- Set c = Nothing
- End With
- End Sub
- '---------------------------------------------------------------------------------------
- 'Sub qui permet de supprimer les lignes de LaPlage
- 'dont les cellules de la colonne LaColonne ne répondant
- 'pas au critères LeCritere
- '---------------------------------------------------------------------------------------
- '
- Private Sub SupprFiltre(LaPlage As Range, ByVal LaColonne As Integer, ByVal LeCritere As String)
- With LaPlage
- .AutoFilter Field:=LaColonne, Criteria1:="<>" & LeCritere
- .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
- .Parent.AutoFilterMode = False
- End With
- End Sub
- '---------------------------------------------------------------------------------------
- 'Sub qui permet d'insérer une ligne de titre entre chaque section
- '---------------------------------------------------------------------------------------
- '
- Private Sub SepareSections(Plage As Range)
- Dim i As Integer, N As Integer
- With Plage
- N = .Rows.Count
- With .Parent
- For i = N To 2 Step -1
- If .Range("D" & i) <> .Range("D" & i - 1) Then
- .Rows(i).Insert
- .Range("A" & i) = "SECTION " & .Range("D" & i + 1)
- With .Range("A" & i & ":C" & i)
- .HorizontalAlignment = xlCenterAcrossSelection
- .Font.Bold = True
- End With
- End If
- Next i
- End With
- End With
- End Sub
|
Merci d'avance pour toute aide complémentaire ou remarque.
Bonne journée,
|