Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionOption Explicit 'Type pour mémoriser les données Private Type tLine Key As String Data As String End Type Public Sub DoTranslation() Dim i As Long Dim ltDatas() As tLine Dim lData As tLine i = 1 ReDim ltDatas(-1 To -1) 'Listage des données Do lData = GetNewData(i) If lData.Data <> "" Then If UBound(ltDatas) = -1 Then ReDim ltDatas(0 To 0) Else ReDim Preserve ltDatas(0 To UBound(ltDatas) + 1) End If ltDatas(UBound(ltDatas)) = lData End If Loop While lData.Data <> "" TraiteDatas ltDatas End Sub Private Function GetNewData(ByRef pLigne As Long) As tLine Dim lValue As tLine Dim lLine As String 'On récupère une nouvelle donnée Do lLine = Cells(pLigne, 1).Value If IsIdLine(lLine) And lValue.Data <> "" Then 'Ligne identifiée, on sort Exit Do ElseIf lLine = "" And lValue.Data <> "" Then 'Plus de données à traiter sur ce jeu, on sort Exit Do End If If IsIdLine(lLine) Then lValue.Key = Split(lLine, " ")(0) lValue.Data = lValue.Data + " " + Mid$(lLine, InStr(lLine, " ") + 1) Else lValue.Data = Trim$(lValue.Data + " " + lLine) End If pLigne = pLigne + 1 Loop While (CStr(Cells(pLigne, 1).Value) + Cells(pLigne + 1, 1).Value + Cells(pLigne + 2, 1).Value) <> "" GetNewData = lValue End Function 'Ligne d'identification ? Private Function IsIdLine(ByVal pLigne As String) As Boolean If pLigne = "" Then IsIdLine = False Else IsIdLine = IsNumeric(Split(pLigne, " ")(0)) End If End Function 'Génération du résultat Private Sub TraiteDatas(ByRef ptDatas() As tLine) Dim i As Long Dim lLigne As Long lLigne = 0 Dim lHeader As Long, lFooter As Long lHeader = -1 Worksheets("Feuil3").Activate Worksheets("Feuil3").Columns("A").Clear For i = LBound(ptDatas) To UBound(ptDatas) If ptDatas(i).Key = "" Then If lHeader <> -1 Then GenerateLignes ptDatas, lHeader, i lHeader = -1 End If ElseIf lHeader = -1 Then lHeader = i - 1 End If Next i Worksheets("Feuil1").Activate End Sub 'Ajout des données dans la Feuil3 Private Sub GenerateLignes(ByRef ptDatas() As tLine, ByVal pHeader As Long, ByVal pFooter As Long) Dim i As Long Dim lLigne As Long With Worksheets("Feuil3") lLigne = 1 Do While .Cells(lLigne, 1).Value <> "" lLigne = lLigne + 1 Loop For i = pHeader + 1 To pFooter - 1 .Cells(lLigne, 1).Value = ptDatas(i).Key .Cells(lLigne, 2).Value = ptDatas(i).Data .Cells(lLigne, 3).Value = ptDatas(pHeader).Data .Cells(lLigne, 4).Value = ptDatas(pFooter).Data lLigne = lLigne + 1 Next End With End Sub