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
| Sub RegrouperLesMesuresSurUneLigne()
Dim ShMesures As Worksheet
Dim AireMesures As Range
Dim CelluleMesure As Range
Dim AireDesCellulesHexa As Range
Dim DerniereLigne As Long
Dim I As Long
Dim J As Long
Dim FichierTexte As Object
Dim LigneFichierTexte As Object
Dim ContenuLigneFichierTexte As Variant
Dim NomDuFichierTxt As Variant
Dim SansEspDefAddName As Variant
ChDir ActiveWorkbook.Path
NomDuFichierTxt = Application.GetSaveAsFilename("nom dossier", "nom dossier (*.txt),*.txt", , "Fichier")
If NomDuFichierTxt = False Then Exit Sub
Set FichierTexte = CreateObject("Scripting.FileSystemObject")
Set LigneFichierTexte = FichierTexte.CreateTextFile(NomDuFichierTxt, True)
Set ShMesures = Sheets("Feuil1")
With ShMesures
'.Range(.Cells(1, 4), .Cells(.UsedRange.Rows.Count, .Columns.Count)).Clear
DerniereLigne = .Cells(.Rows.Count, 2).End(xlUp).Row
Set AireMesures = .Range(.Cells(1, 2), .Cells(DerniereLigne, 2))
For Each CelluleMesure In AireMesures
If CelluleMesure <> "" Then
SansEspDefAddName = Split(LTrim(CelluleMesure), " ")(0)
ContenuLigneFichierTexte = SansEspDefAddName & "_INIT;"
If CelluleMesure.MergeCells = True Then
Set AireDesCellulesHexa = CelluleMesure.MergeArea
J = 0
For I = AireDesCellulesHexa.Count To 1 Step -1
ContenuLigneFichierTexte = ContenuLigneFichierTexte & AireDesCellulesHexa.Cells(I, 1).Offset(0, 1) & ";"
' CelluleMesure.Offset(0, 2 + J) = AireDesCellulesHexa.Cells(I, 1).Offset(0, 1)
' J = J + 1
Next I
ContenuLigneFichierTexte = Mid(ContenuLigneFichierTexte, 1, Len(ContenuLigneFichierTexte) - 1)
LigneFichierTexte.writeline (ContenuLigneFichierTexte)
Set AireDesCellulesHexa = Nothing
Else
ContenuLigneFichierTexte = ContenuLigneFichierTexte & CelluleMesure.Offset(0, 1)
LigneFichierTexte.writeline (ContenuLigneFichierTexte)
' CelluleMesure.Offset(0, 2) = CelluleMesure.Offset(0, 1)
End If
End If
Next CelluleMesure
Set AireMesures = Nothing
End With
LigneFichierTexte.Close
Set LigneFichierTexte = Nothing
Set FichierTexte = Nothing
Set ShMesures = Nothing
End Sub |
Partager