[RESOLU] Simplification Macro

[Florian53]

Bonjour à tous,

J'ai pris par si par là quelques bout de macro afin de réaliser un fichier qui extrait les données d'un fichier texte pour remettre en forme toutes les données par la suite. Je trouve que temps de traitement est un peu long, est ce que ça pourrais être du au code qui pourrais certainement plus harmonieux ?

J'ai pris la Macro de Boisgontier Jacques pour extraire les données.

Private Sub UserForm_Initialize()
  ChDir ThisWorkbook.Path
  Me.Dossier = CurDir()
  Me.ChoixFichier.Clear
  nf = Dir("*.txt")               ' premier
  Do While nf <> ""
    Me.ChoixFichier.AddItem nf
    nf = Dir                       ' suivant
  Loop
  End Sub
Private Sub b_dossier_Click()
  ChDir ThisWorkbook.Path
  With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = CurDir() & "\"
    .Show
    If .SelectedItems.Count > 0 Then
       Me.Dossier = .SelectedItems(1)
       ChDir Me.Dossier
    End If
  End With
End Sub
Private Sub B_ok_Click()

    FichierActuel = ThisWorkbook.Name
    Workbooks.OpenText Filename:=Me.Dossier & "\" & Me.ChoixFichier, _
        Origin:=xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
        xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=True, _
        Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
        Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1))
        Set wbk = ActiveWorkbook
    Selection.CurrentRegion.Copy
    Windows(FichierActuel).Activate
    Range("A2").Select
    ActiveSheet.Paste
    Selection.HorizontalAlignment = xlCenter
    '--- 1ere ligne en gras
    Range("A1:E1").Select
    Range("A1", [A1].End(xlToRight)).Font.Bold = True
    Selection.Font.Bold = True
    '--- Insertion texte dans cellule
    Range("A1") = "Numéro"
    Range("B1") = "Thermostat ON"
    '--- cadre
    [A2].CurrentRegion.BorderAround Weight:=xlThin
     '--- Supression des colonnes inutiles
    Range("c:c").Delete
    Range("d:d").Delete
      '--- Fermeture du fichier Texte
    wbk.Close
    '--- Insertion texte dans cellule
    Range("c1") = "Thermostat OFF"
    Range("D1") = "Presence Eau"
    '--- Auto centrage des colonnes
    Columns("A:E").Columns.AutoFit
     '--- Supression information de la colonne A
    Call deleteinfos1
      '--- Supression information de la colonne C
    Call deleteinfos2
    Unload F_visuTxt
    '--- Mise en forme de la première ligne ( couleur & bordures )
     Range("A1:D1").Select
    With Selection.Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.399975585192419
        .PatternTintAndShade = 0
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With

End Sub



Sub deleteinfos1()
    Dim i As Range

    With Sheets("Feuil1")
        Set i = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
    End With
    For Each cell In i
       If cell.Value = "Tps bascule ON" Then
        Range(cell.Address).ClearContents
       End If
       Next
   
End Sub


Sub deleteinfos2()
    Dim j As Range

    With Sheets("Feuil1")
        Set j = .Range("c1:c" & .Range("c65536").End(xlUp).Row)
    End With
    For Each cell In j
       If cell.Value = "Tps bascule OFF" Then
        Range(cell.Address).ClearContents
       End If
       Next
   
End Sub

 

[Florian53]

Voici les fichiers en question

 

[M12]

Bonjour, un test de mon côté

0.79 secondes
Je ne pense pas pouvoir faire mieux

 

[Florian53]

c'est excel qui ressort un temps ( 0,79 s) ou c'est avec une macro que vous chronométré l'exécution ?

J'ai l'impression que par moment l'userform ne s'initialise pas correctement, il faut le fermer puis le re ouvrir afin de voir si un fichier texte se trouve dans un dossier, il n’apparaît pas toujours du premier coup ?
Est ce que ce problème vient de mon pc ?

 

[M12]

Re,
A mettre au début de la procédure

Dim temp As Single
temp = Timer


à mettre à la fin de la procédure avant le END SUB

MsgBox Timer - temp

 

[Florian53]

J'ai 12,9 secondes comme résultat, pourtnt mon pc est un core i3 avec 4 go de ram !!!! le problème vient du pc ?

 

[M12]

Re,

Teste ta macro en pas à pas (Touche F8) pour vérifier qu'elle ne part pas dans un autre module qui n'a rien à voir avec la procédure

 

[Florian53]

J'ai l'impression que c'est ce code qui me prends beaucoup de temps quand je vais en pas à pas , sinon je ne vois rien d'autre

Sub deleteinfos1()
    Dim i As Range

    With Sheets("Feuil1")
        Set i = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
    End With
    For Each cell In i
       If cell.Value = "Tps bascule ON" Then
        Range(cell.Address).ClearContents
       End If
       Next
 
End Sub

Si j'enleve deleteinfo je passe à 0,42 secondes. C'est bien ça qui me pose soucis mais je ne comprends pas pourquoi

 

[Dranreb]

Bonjour.
Parce que chaque accès à une plage d'un nombre quelconque de cellules elle long en soit.
Alors je m'arrange très souvent pour n'en avoir que 2 en tout et pour tout: 1 au début et 1 à la fin. Comme ça :

Sub deleteinfos1()
Dim R As Range, T(), L As Long
With Sheets("Feuil1")
    Set R = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
End With
T = R.Value
For L = 1 To UBound(T, 1)
   If T(L, 1) = "Tps bascule ON" Then T(L, 1) = Empty
   Next L
R.Value = T
End Sub

 

[Florian53]

je ne comprends pas trop la démarche mais après essai le chrono passe à 0,5 secondes. Donc très efficace un grand merci à vous 2.