Option Explicit
Sub Import_Somme()
Dim MaxLignesExcel&, MaxLignesBloc&
Dim DebutLigneImport&, FinligneImport&, NumOnglet&
Dim MonFichierText, MonDossierText, NumFichier&, LigneText&, nLig&
Dim Tablo, Aux, i&, j&, k&, m&, Ntot&, Nenrgt&, T0!
T0 = Timer
Application.ScreenUpdating = True
MaxLignesBloc = Range("b14")
MaxLignesExcel = Range("b15")
nLig = 1
MonFichierText = Application.GetOpenFilename("Text Files (*.txt), *.txt")
If MonFichierText = False Then
MsgBox "Aucun Fichier sélectionné -> FIN"
ThisWorkbook.Close SaveChanges:=False
Exit Sub
End If
T0 = Timer
Tablo = Split(MonFichierText, "\")
ReDim Preserve Tablo(LBound(Tablo) To UBound(Tablo) - 1)
MonDossierText = Join(Tablo, "\") & "\"
Workbooks.Add
ActiveWorkbook.SaveAs MonDossierText & "FichierSomme" & _
Format(Date, """-a""yyyy""m""mm""j""dd") & _
Format(Time, """-h""hh""m""mm""s""ss")
Range("A1") = "leTexte": Range("B1") = "laSomme"
NumOnglet = NumOnglet + 1: ActiveSheet.Name = "Res-" & NumOnglet
NumFichier = FreeFile
Open MonFichierText For Input As #NumFichier
Application.DisplayStatusBar = True
Application.ScreenUpdating = False
Do
'lecture par bloc de MaxLignesBloc lignes
j = 0: ReDim Tablo(0 To 1, 0 To MaxLignesBloc - 1)
Do While Not EOF(NumFichier) And j < MaxLignesBloc And nLig < MaxLignesExcel
Line Input #NumFichier, Tablo(0, j)
nLig = nLig + 1: j = j + 1: Nenrgt = Nenrgt + 1
Loop
'traitement du bloc
If j > 0 Then
ReDim Preserve Tablo(0 To 1, 0 To j - 1)
For k = 0 To j - 1
Aux = Split(Tablo(0, k))
Tablo(1, k) = 0
For m = UBound(Aux) - 6 To UBound(Aux)
Tablo(1, k) = Tablo(1, k) + Val(Aux(m))
Next m
Next k
Cells(MaxLignesExcel, 1).End(xlUp).Offset(1).Resize(UBound(Tablo, 2) + 1, 2) = _
Application.Transpose(Tablo)
End If
If EOF(NumFichier) Then
'fin du traitement car fin de fichier
Columns("A:B").EntireColumn.AutoFit
Application.StatusBar = False
MsgBox "Fin du Traitement. " & Format(Nenrgt, "# ### ##0") & " lignes traitées" & vbCrLf & vbCrLf & _
"durée traitement: " & Format(Timer - T0, "0.0") & " s"
ThisWorkbook.Close SaveChanges:=False
Exit Sub
ElseIf nLig = MaxLignesExcel Then
'ajouter un onglet vierge Columns("A:B").EntireColumn.AutoFit
Columns("A:B").EntireColumn.AutoFit
Sheets.Add after:=Worksheets(Worksheets.Count)
Range("A1") = "leTexte": Range("B1") = "laSomme"
NumOnglet = NumOnglet + 1: ActiveSheet.Name = "Res-" & NumOnglet
nLig = 1
End If
'patience
Ntot = Ntot + 1
Application.StatusBar = "Bloc n°: " & Ntot & " / " & Format(Nenrgt, "# ### ##0")
DoEvents
Loop
Close #NumFichier ' Ferme le fichier.
End Sub
