Ce site web utilise les cookies.

Les données stockées par ces cookies nous permermettent de personnaliser le contenu des annonces, d'offrir des fonctionnalités relatives aux réseaux sociaux et d'analyser notre trafic. Nous partageons également certains cookies et des informations sur l'utilisation de notre site avec nos partenaires de médias sociaux, de publicité et d'analyse, qui peuvent combiner celles-ci avec d'autres informations que vous leur avez fournies ou qu'ils ont collectées lors de votre utilisation de leurs services. Nos partenaires sont Google et ses partenaires tiers.

Plus d'informations Refuser Accepter
Retour à l'index

Nous sommes le 29 Mar 2024, 09:29

Heures au format UTC + 1 heure [ Heure d’été ]




Répondre  Nouveau topic  [ 12 messages ] 
Auteur Message
MessagePosté: 24 Mar 2022, 11:59 
Nouveau Membre
Nouveau Membre

Inscription: 21 Nov 2021, 13:32
Messages: 13
Département: 57

Audi A3 Cab 2.0 TFSI 200Ch
S-Line de Aoû 2008
Bonjour,
J'ai créer une macro Excel qui permet d'améliorer la présentation des scans du vagcom et qui crée 2 fichiers pdf.
Le premier avec l'intégralité du scan
Le second avec uniquement les erreurs.
Si cela peux être utile ou rendre service ???
Image

Le fichier scan est demandé en début de macro.
Les pdfs sont crées dans le dossier contenant le scan et sont nommés comme le fichier scan avec comme extensions .pdf et _err.pdf

Lien vers la macro : http://gsacrip.free.fr/Macro.txt

Spoiler, cliquez moi pour afficher le texte

Sub Auto_open()
'
' Macro1 Macro
'
'
' === Ouverture Fichier ===
DefaultFilePath = ThisWorkbook.Path
Sortie = 0
Do Until Sortie = 1
MonFichier = Application.GetOpenFilename("Text Files (*.txt), *.txt")
If MonFichier = "Faux" Then
Rep = MsgBox("Vous n'avez pas sélectionné de fichier", vbRetryCancel, "Que fait-on ?")
If Rep = vbCancel Then
If Left(Environ("COMPUTERNAME"), 3) = "GS-" Then
Exit Sub
Else
ThisWorkbook.Close
Application.Quit
End If
End If
Else
Sortie = 1
End If
Loop

' === Effacer feuille 1 ===
Sheets("Feuil1").Select
Cells.Select
Selection.Font.Bold = False
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
Selection.ClearContents
Columns("A:A").ColumnWidth = 71
Range("A1").Select

' === Charger fichier ===
i = 0
IndexFichier = FreeFile()
Open MonFichier For Input As #IndexFichier
While Not EOF(IndexFichier)
Line Input #IndexFichier, Maligne
If MalignePre <> Maligne Then
i = i + 1
Range("A" & i) = Maligne
MalignePre = Maligne
End If
Wend
Close #IndexFichier

Dernl = i

For i = 1 To Dernl
If Range("A" & i).Value Like "*Etat: OK*" Then
Range("A" & i).Font.ColorIndex = 50
Range("A" & i).Font.Bold = True
End If
If Range("A" & i).Value Like "*Etat: Défaut*" Then
Range("A" & i).Font.ColorIndex = 3
Range("A" & i).Font.Bold = True
End If
'
If Range("A" & i).Value Like "-----*" Then
Range("A" & i).Font.Bold = True
Range("A" & i + 1).Font.Bold = True
End If
'
If Range("A" & i).Value Like "Scanner: *" Then
Range("A" & i) = Range("A" & i) & " " & Range("A" & i + 1)
Range("A" & i + 1) = ""
End If

Next i

Entete = 0
For i = 1 To Dernl
If Range("A" & i).Value Like "-----*" Then
Range("A" & i).Font.Bold = True
Entete = i + 1
End If
If Range("A" & i).Value Like "Aucun code défaut trouvé*" Then
Range("A" & Entete).Font.ColorIndex = 50
Else
If Range("A" & i).Value Like "*défaut trouvé*" Then
Range("A" & Entete).Font.ColorIndex = 3
For j = i To Dernl
If Range("A" & j).Value Like "-----*" Then
Exit For
End If
X_LignErr = Left(Range("A" & j).Value, 5)
If IsNumeric(X_LignErr) = True Then
Range("A" & j).Font.ColorIndex = 5
Range("A" & j).Font.Bold = True
Application.CutCopyMode = False
Range("B" & j).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
"https://wiki-ross--tech-com.translate.goog/wiki/index.php/" & X_LignErr & "?_x_tr_sl=en&_x_tr_tl=fr&_x_tr_hl=fr&_x_tr_sch=http", TextToDisplay:="Voir Wiki"
Range("B" & j + 1).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
"https://www.gerritspeek.nl/vag-com_dtc-" & X_LignErr & ".html", TextToDisplay:="Voir gerritspeek.nl"
Application.CutCopyMode = True
End If
Next j
End If
End If

Next i

MonFichier = Replace(MonFichier, ".txt", ".pdf")
With ActiveSheet.PageSetup
.FitToPagesWide = 1
.FitToPagesTall = 100
End With
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=MonFichier, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
'

' === Copie erreur sur feuille2 ===

Sheets("Feuil1").Select
Range(Columns(1), Columns(2)).Select
Selection.Copy
Sheets("Feuil2").Select
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select

' === Position premier calculateur ===
For i = 1 To Dernl
If Range("A" & i).Value Like "-----*" Then
Exit For
End If
Next i

' === Effacement calculateurs OK ===
For i = i + 1 To Dernl
If Range("A" & i).Font.ColorIndex = 50 Then
For j = i To Dernl
Rows(i).EntireRow.Delete
Dernl = Dernl - 1
If Range("A" & i).Value Like "-----*" Then
Rows(i).EntireRow.Delete
i = i - 1
Dernl = Dernl - 1
Exit For
End If
Next j
End If
Next i

MonFichier = Replace(MonFichier, ".pdf", "_err.pdf")
With ActiveSheet.PageSetup
.FitToPagesWide = 1
.FitToPagesTall = 100
End With
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=MonFichier, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

Sheets("Feuil1").Select
Range("A1").Select
ThisWorkbook.Close Savechanges:=False
Application.Quit
End Sub


Je n'arrive pas à mettre un lien direct pour le téléchargement du classeur; vous pouvez me le demander en MP.


Dernière édition par Mouflon57 le 27 Mar 2022, 18:42, édité 5 fois.

Haut | Bas
MessagePosté: 24 Mar 2022, 13:39 
Avatar de l’utilisateur
Contributeur Technique
Contributeur Technique

Inscription: 10 Juil 2010, 11:57
Messages: 3162
Localisation: Compiegne
Département: 60

Audi A3 2.0 TDI 140Ch
Ambition Luxe de Oct 2005
Slt

Merci pour ta participation mais je comprend pas à quoi ça sert.



Envoyé de mon SM-G960F en utilisant Tapatalk

_________________
Aucun support ou autre en MP


Haut | Bas
MessagePosté: 24 Mar 2022, 15:06 
Nouveau Membre
Nouveau Membre

Inscription: 21 Nov 2021, 13:32
Messages: 13
Département: 57

Audi A3 Cab 2.0 TFSI 200Ch
S-Line de Aoû 2008
A pas grand chose sauf à bien mettre en exergue les défauts


Haut | Bas
MessagePosté: 24 Mar 2022, 23:36 
Avatar de l’utilisateur
Contributeur Technique
Contributeur Technique

Inscription: 10 Juil 2010, 11:57
Messages: 3162
Localisation: Compiegne
Département: 60

Audi A3 2.0 TDI 140Ch
Ambition Luxe de Oct 2005
Re

Ah ok.
Donc, quand il y a un défaut, il est écrit en rouge ?

Afin de le voir plus facilement.

Envoyé de mon SM-G960F en utilisant Tapatalk

_________________
Aucun support ou autre en MP


Haut | Bas
MessagePosté: 25 Mar 2022, 11:26 
Nouveau Membre
Nouveau Membre

Inscription: 21 Nov 2021, 13:32
Messages: 13
Département: 57

Audi A3 Cab 2.0 TFSI 200Ch
S-Line de Aoû 2008
Oui l'adresse est en rouge
Adresse 08: Climatronic Labels: 8P0-820-043.lbl

et le(s) code(s) défaut en bleu.
01333 - Calculateur de porte AR G (J388)
01331 - Calculateur de porte côté conducteur (J386)


Sur la feuil2, seules les adresses avec défaut sont extraites, ce qui réduit les recherches et le volume à imprimer (si besoin).


Haut | Bas
MessagePosté: 26 Mar 2022, 09:59 
Nouveau Membre
Nouveau Membre

Inscription: 21 Nov 2021, 13:32
Messages: 13
Département: 57

Audi A3 Cab 2.0 TFSI 200Ch
S-Line de Aoû 2008
J'ai modifié la macro, désormais sur le rapport, en face de chaque erreur figurent 2 liens cliquables pointant sur :
    Le wiki
    Gerritspeek

Have big fun

Image


Dernière édition par Mouflon57 le 27 Mar 2022, 18:16, édité 1 fois.

Haut | Bas
MessagePosté: 26 Mar 2022, 11:09 
Avatar de l’utilisateur
Contributeur Technique
Contributeur Technique

Inscription: 10 Juil 2010, 11:57
Messages: 3162
Localisation: Compiegne
Département: 60

Audi A3 2.0 TDI 140Ch
Ambition Luxe de Oct 2005
Slt

Merci pour ta participation

Envoyé de mon SM-G960F en utilisant Tapatalk

_________________
Aucun support ou autre en MP


Haut | Bas
MessagePosté: 26 Mar 2022, 14:16 
Avatar de l’utilisateur
Moderateur
Moderateur

Inscription: 09 Avr 2012, 14:59
Messages: 12170
Localisation: 94 et 45
Département: 94

Audi S3 2.0 TFSI 300Ch
S de Sep 2017
Salut et merci pour ce topic !
Je viens de le mettre en « post-it » pour qu’il reste visible en haut de la page
:merci:

_________________
ZIPPO4594

/!\ HORS MEMBRES GRADES, PAS DE SUPPORT PAR MP - POSEZ VOS QUESTIONS SUR LE FORUM /!\
/!\ Pas d’aide d’ordre technique tant que la présentation de la voiture n’a pas été faite en bonne et due forme ! /!\
Nous sommes un forum communautaire et non pas une hotline Audi
> Règles du forum à lire et à relire <
La modération se réserve le droit de verrouiller ou de supprimer tout message ne respectant pas le règlement du forum


Haut | Bas
MessagePosté: 27 Mar 2022, 09:01 
Nouveau Membre
Nouveau Membre

Inscription: 21 Nov 2021, 13:32
Messages: 13
Département: 57

Audi A3 Cab 2.0 TFSI 200Ch
S-Line de Aoû 2008
:hop: Merci


Haut | Bas
MessagePosté: 26 Nov 2023, 14:55 
Avatar de l’utilisateur
Nouveau Membre
Nouveau Membre

Inscription: 21 Juil 2023, 19:05
Messages: 21
Département: Belgique

Audi A3 1.9 TDI 105Ch
Ambition de Déc 2007
Salut Mouflon,

Il a l'air d'être chouette cette macro parce que c'est assez compliqué d'avoir un beau visuel sur Notepad haha, peux-tu l'upload sur un site récent, car ton lien ne fonctionne pas :(

Merci l'ami !


Haut | Bas
MessagePosté: 26 Nov 2023, 16:51 
Nouveau Membre
Nouveau Membre

Inscription: 21 Nov 2021, 13:32
Messages: 13
Département: 57

Audi A3 Cab 2.0 TFSI 200Ch
S-Line de Aoû 2008
Bonjour,

Désolé, j'ai malencontreusement effacé la macro du serveur.
Tout est rentré dans l'ordre.
Avec toutes excuses ....
Lien vers la macro: http://gsacrip.free.fr/Macro.txt

Spoiler, cliquez moi pour afficher le texte

Sub Auto_open()
'
' Macro1 Macro
'
'
' === Ouverture Fichier ===
DefaultFilePath = ThisWorkbook.Path
Sortie = 0
Do Until Sortie = 1
MonFichier = Application.GetOpenFilename("Text Files (*.txt), *.txt")
If MonFichier = "Faux" Then
Rep = MsgBox("Vous n'avez pas sélectionné de fichier", vbRetryCancel, "Que fait-on ?")
If Rep = vbCancel Then
If Left(Environ("COMPUTERNAME"), 3) = "GS-" Then
Exit Sub
Else
ThisWorkbook.Close
Application.Quit
End If
End If
Else
Sortie = 1
End If
Loop

' === Effacer feuille 1 ===
Sheets("Feuil1").Select
Cells.Select
Selection.Font.Bold = False
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
Selection.ClearContents
Columns("A:A").ColumnWidth = 71
Range("A1").Select

' === Charger fichier ===
i = 0
IndexFichier = FreeFile()
Open MonFichier For Input As #IndexFichier
While Not EOF(IndexFichier)
Line Input #IndexFichier, Maligne
If MalignePre <> Maligne Then
i = i + 1
Range("A" & i) = Maligne
MalignePre = Maligne
End If
Wend
Close #IndexFichier

Dernl = i

For i = 1 To Dernl
If Range("A" & i).Value Like "*Etat: OK*" Then
Range("A" & i).Font.ColorIndex = 50
Range("A" & i).Font.Bold = True
End If
If Range("A" & i).Value Like "*Etat: Défaut*" Then
Range("A" & i).Font.ColorIndex = 3
Range("A" & i).Font.Bold = True
End If
'
If Range("A" & i).Value Like "-----*" Then
Range("A" & i).Font.Bold = True
Range("A" & i + 1).Font.Bold = True
End If
'
If Range("A" & i).Value Like "Scanner: *" Then
Range("A" & i) = Range("A" & i) & " " & Range("A" & i + 1)
Range("A" & i + 1) = ""
End If

Next i

Entete = 0
For i = 1 To Dernl
If Range("A" & i).Value Like "-----*" Then
Range("A" & i).Font.Bold = True
Entete = i + 1
End If
If Range("A" & i).Value Like "Aucun code défaut trouvé*" Then
Range("A" & Entete).Font.ColorIndex = 50
Else
If Range("A" & i).Value Like "*défaut trouvé*" Then
Range("A" & Entete).Font.ColorIndex = 3
For j = i To Dernl
If Range("A" & j).Value Like "-----*" Then
Exit For
End If
X_LignErr = Left(Range("A" & j).Value, 5)
If IsNumeric(X_LignErr) = True Then
Range("A" & j).Font.ColorIndex = 5
Range("A" & j).Font.Bold = True
Application.CutCopyMode = False
Range("B" & j).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
"https://wiki-ross--tech-com.translate.goog/wiki/index.php/" & X_LignErr & "?_x_tr_sl=en&_x_tr_tl=fr&_x_tr_hl=fr&_x_tr_sch=http", TextToDisplay:="Voir Wiki"
Range("B" & j + 1).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
"https://www.gerritspeek.nl/vag-com_dtc-" & X_LignErr & ".html", TextToDisplay:="Voir gerritspeek.nl"
Application.CutCopyMode = True
End If
Next j
End If
End If

Next i

MonFichier = Replace(MonFichier, ".txt", ".pdf")
With ActiveSheet.PageSetup
.FitToPagesWide = 1
.FitToPagesTall = 100
End With
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=MonFichier, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
'

' === Copie erreur sur feuille2 ===

Sheets("Feuil1").Select
Range(Columns(1), Columns(2)).Select
Selection.Copy
Sheets("Feuil2").Select
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select

' === Position premier calculateur ===
For i = 1 To Dernl
If Range("A" & i).Value Like "-----*" Then
Exit For
End If
Next i

' === Effacement calculateurs OK ===
For i = i + 1 To Dernl
If Range("A" & i).Font.ColorIndex = 50 Then
For j = i To Dernl
Rows(i).EntireRow.Delete
Dernl = Dernl - 1
If Range("A" & i).Value Like "-----*" Then
Rows(i).EntireRow.Delete
i = i - 1
Dernl = Dernl - 1
Exit For
End If
Next j
End If
Next i

MonFichier = Replace(MonFichier, ".pdf", "_err.pdf")
With ActiveSheet.PageSetup
.FitToPagesWide = 1
.FitToPagesTall = 100
End With
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=MonFichier, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

Sheets("Feuil1").Select
Range("A1").Select
ThisWorkbook.Close Savechanges:=False
Application.Quit
End Sub


Haut | Bas
MessagePosté: 28 Nov 2023, 00:11 
Avatar de l’utilisateur
Nouveau Membre
Nouveau Membre

Inscription: 21 Juil 2023, 19:05
Messages: 21
Département: Belgique

Audi A3 1.9 TDI 105Ch
Ambition de Déc 2007
Re,

Top, merci à toi ! :hop:


Haut | Bas
Afficher les messages postés depuis:  Trier par  
Répondre  Nouveau topic  [ 12 messages ] 

Heures au format UTC + 1 heure [ Heure d’été ]


Qui est en ligne

Utilisateurs parcourant ce forum: Aucun utilisateur enregistré et 8 invités


Vous ne pouvez pas poster de nouveaux sujets
Vous ne pouvez pas répondre aux sujets
Vous ne pouvez pas éditer vos messages
Vous ne pouvez pas supprimer vos messages

   Topics similaires   Auteur   Réponses   Vus   Dernier message 
Aucun nouveau message non-lu dans ce sujet. Présentation

dans Nouveaux

chamil

1

514

14 Mai 2023, 10:49

ZIPPO4594 Voir le dernier message

Aucun nouveau message non-lu dans ce sujet. Présentation

dans Nouveaux

Miguelito

3

597

15 Mai 2023, 21:17

ZIPPO4594 Voir le dernier message

Aucun nouveau message non-lu dans ce sujet. présentation

dans Nouveaux

Beetlejuice83

1

257

01 Mai 2023, 12:31

ZIPPO4594 Voir le dernier message

Aucun nouveau message non-lu dans ce sujet. Présentation

dans Nouveaux

Teddy62

1

328

07 Mai 2023, 20:35

ZIPPO4594 Voir le dernier message


Rechercher:
Développé par phpBB® Forum Software © phpBB Group
Traduction par phpBB-fr.com
phpBB SEO
Cookies - CGU
[ Time : 0.172s | 22 Queries | GZIP : Off ]