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.
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.
VB:
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