Option Explicit
Sub LegendeTest()
Dim Nff As Byte, Pth As String, Txt() As String, oS1 As Worksheet, oS2 As Worksheet
Dim FcNm As String, i As Long, Rw1 As Long, NLn As Long, Rw2 As Long, j As Long
Set oS1 = Worksheets("Feuil1"): Set oS2 = Worksheets("Feuil2")
Pth = ThisWorkbook.Path: Nff = FreeFile: FcNm = "Test" & Nff & ".txt"
Rw1 = oS1.Cells(Rows.Count, 4).End(xlUp).Row: If Rw1 = 1 Then Exit Sub
ReDim Txt(1 To 3): Txt(1) = "TEST 1": Txt(3) = "RESULTAT DE TEST": NLn = 3
Rw2 = oS2.Cells(Rows.Count, 1).End(xlUp).Row
i = 2
Do
If Trim(oS1.Cells(i, 1)) <> "" And Trim(oS1.Cells(i, 1)) <> "." Then
If Trim(oS1.Cells(i, 2)) <> "" And Trim(oS1.Cells(i, 2)) <> "." Then
NLn = NLn + 3: ReDim Preserve Txt(1 To NLn)
Txt(NLn) = oS1.Cells(i, 1) & " " & oS1.Cells(i, 2) & " " & oS1.Cells(i, 3)
NLn = NLn + Rw2 - 1: ReDim Preserve Txt(1 To NLn)
j = 2
Do
Txt(NLn - Rw2 + j) = " " & oS2.Cells(j, 1) & " " & oS2.Cells(j, 2) & " " & oS2.Cells(j, 2)
j = j + 1
Loop Until j > Rw2
End If
Else
If Trim(oS1.Cells(i, 4)) <> "" And Trim(oS1.Cells(i, 4)) <> "." Then
NLn = NLn + 1: ReDim Preserve Txt(1 To NLn)
Txt(NLn) = " " & oS1.Cells(i, 4) & " " & oS1.Cells(i, 5) & " " & oS1.Cells(i, 6)
End If
End If
i = i + 1
Loop Until i > Rw1
Call WriteNLine(Txt(), NLn, FcNm, Pth, Nff)
Set oS1 = Nothing: Set oS2 = Nothing
End Sub
Sub WriteNLine(vStr() As String, NbRw As Long, vFnm As String, vPth As String, vNff As Byte)
Dim i As Long
Open vPth & "\" & vFnm For Output As #vNff
i = 1
Do
Print #vNff, vStr(i)
i = i + 1
Loop Until i > NbRw
Close #vNff
End Sub