probleme codage en VBA

probleme codage en VBA - VB/VBA/VBS - Programmation

Marsh Posté le 20-04-2017 à 07:23:00    

bonjour a tous,
je cherche une solution à mon problème  :pt1cable:  
Les conditions:
Je reçois par jour environ 150 mails, dont je souhaite extraire uniquement leurs contenus qui sont:
Sujet :
Acquisition Nø04 aLPHA: 211
De :
SCS <admin@xxxx.com>
Pour :
<contact@xxxxx.com>
Copie à :
<admin@xxxx.com>
 
Le 14/04/2017  14h27mn38s
C1
H1=10,00mm/s H2=1,28mm/s V=2,65mm/s

C2
H1=7,35mm/s H2=1,37mm/s V=2,65mm/s[/#F0FF00]

 
En orange sont les données qui changent à chaque réception de mail.
Mon but étant d’insérer de manière auto (VBA sous excel) chaque emails transformés en .txt pour ensuite utiliser la masse importante de donnée et faire des graph et autres
 
Je souhaite bien evidement changer le format du fichier text et suprimer toutes les lignes et espaces pour en faire qu'une ligne par .txt, comme suit:
 
14/04/2017;14h29mn38s;C1;H1=12,00mm/s;H2=12,28mm/s;V=22,65mm/s;C2;H1=7,35mm/s;H2=1,37mm/s;V=2,65mm/s;
 
 
Problèmes actuels en VBA
Evidemment je débute en VBA, en remerciant pour votre indulgence  :)  
 
Je n'ai pas trouvé encore la solution pour modifier le contenu du fichier txt d'origine en avec fichier txt avec une seule ligne avec la séparation ";"
 
Sinon:
1/dans le secteur Private Sub modifier_texte_Click()
j'ai un message d'erreur sur cette ligne Dim fso As FileSystemObject
 
2/J essaye de supprimer les doublons, seule la colonne "heure" doit être prise en compte et si la condition est validée elle doit pouvoir supprimer toute la ligne.
 
 
mon code actuel  :sweat: :

Code :
  1. Dim ligne_debut As Integer: Dim colonne_debut As Integer
  2. Dim ligne_fin As Integer: Dim colonne_fin As Integer
  3. Dim ligne_enCours As Integer: Dim colonne_enCours As Integer
  4. Private Sub exporter_Click()
  5. Dim nom_fichier As String
  6. ligne_debut = 2: colonne_debut = 2
  7. ligne_enCours = ligne_debut: colonne_enCours = colonne_debut
  8. Cells.Clear
  9. For i = 0 To liste_fichiers.ListCount - 1
  10.     lecture (liste_fichiers.List(i))
  11. Next i
  12. Traitement
  13. nom_fichier = Application.GetSaveAsFilename(fileFilter:="Text Files (*.txt),*.txt" )
  14. sortie.Value = nom_fichier
  15. ecriture (nom_fichier)
  16. End Sub
  17. Private Sub fermer_Click()
  18. liste_fichiers.Clear
  19. formulaire.Hide
  20. End Sub
  21. Private Sub importer_Click()
  22. Dim fichier_choisi As String
  23. fichier_choisi = Application.GetOpenFilename("Text Files (*.txt),*.txt", , "Sélectionner le fichier CSV" )
  24. If (LCase(fichier_choisi) <> "faux" And fichier_choisi <> "0" ) Then
  25.     liste_fichiers.AddItem (fichier_choisi)
  26. End If
  27. End Sub
  28. Private Sub liste_fichiers_Click()
  29. End Sub
  30. Private Sub modifier_texte_Click()
  31. Dim str As String
  32. Dim fso As FileSystemObject ' AJOUTER LA REFERENCE (VOIR FAQ SI BESOIN)
  33. Dim fs As Folder
  34. Dim ts As TextStream
  35. Dim pathaouvrir As Variant
  36. Set fso = New FileSystemObject
  37. ' ouvre le fichier
  38. Set fs = fso.GetFolder("D:\tintintitn\lalalala\" )
  39. pathaouvrir = Application.GetOpenFilename("Text Files (*.txt),*.txt", , "Sélectionner le fichier CSV" )
  40.     If pathaouvrir <> False Then
  41.     'vérifions toujours que le fichier existe
  42.     If Dir(pathaouvrir) <> "" Then
  43.     Set ts = fso.OpenTextFile(pathaouvrir)
  44.     ' met tout le contenu dans une variable
  45.         str = ts.ReadAll
  46.         ts.Close
  47.     ' remplace
  48.     str = Replace(str, "C1H1=", "C1;H1 = " )
  49.     ' on écrase
  50.     Set ts = fso.createtextfile(pathaouvrir, True)
  51.         ts.write str
  52.         ts.Close
  53. End If
  54. End Sub
  55. Private Sub sortie_Change()
  56. End Sub
  57. Private Sub UserForm_Click()
  58. End Sub
  59. Private Sub lecture(Fichier As String)
  60. Dim depart As Integer, position As Integer
  61. Dim texte As String, tampon As String
  62. Open Fichier For Input As #1
  63. Do While Not EOF(1)
  64.     Line Input #1, texte
  65.     depart = 1: position = 1
  66.     Do While (position <> 0)
  67.         position = InStr(depart, texte, ";", 1)
  68.         If position = 0 Then
  69.             tampon = Mid(texte, depart)
  70.             Sheets("Import" ).Cells(ligne_enCours, colonne_enCours).Value = tampon
  71.             Exit Do
  72.         Else
  73.             tampon = Mid(texte, depart, position - depart)
  74.         End If
  75.        
  76.         Sheets("Import" ).Cells(ligne_enCours, colonne_enCours).Value = tampon
  77.         depart = position + 1
  78.         colonne_enCours = colonne_enCours + 1
  79.        
  80.     Loop
  81.    
  82.     colonne_enCours = colonne_debut
  83.     ligne_enCours = ligne_enCours + 1
  84.    
  85. Loop
  86. Close #1
  87. End Sub
  88. Private Sub ecriture(Fichier As String)
  89. Dim ligne As Integer, colonne As Integer
  90. Dim texte As String
  91. ligne = ligne_debut: colonne = colonne_debut
  92. If LCase(Fichier) <> "faux" Then
  93. Open Fichier For Output As #1
  94.     While Cells(ligne, colonne).Value <> ""
  95.         While Cells(ligne, colonne).Value <> ""
  96.             texte = texte & Cells(ligne, colonne).Value & ";"
  97.                                  
  98.             colonne = colonne + 1
  99.         Wend
  100.         Print #1, texte
  101.         texte = ""
  102.         colonne = colonne_debut
  103.         ligne = ligne + 1
  104.        
  105.        
  106.     Wend
  107.    
  108.    
  109. Close #1
  110. End If
  111. End Sub
  112. Sub SupprimeDoublons()
  113.     Dim Plage As Range, Cell As Range
  114.     Dim Un As New Collection
  115.     Dim Tableau() As Integer
  116.     Dim x As Integer
  117.     'Définit la plage de cellules pour la recherche de doublons
  118.     Set Plage = Worksheets("Import" ).Range("c2:c99999" )
  119.     On Error Resume Next
  120.     'Boucle sur les cellules de la plage cible
  121.     For Each Cell In Plage
  122.         'Création d'une collection de données uniques (sans doublons)
  123.         Un.Add Cell, CStr(Cell)
  124.         'Une erreur survient si l'élément existe dans la collection.
  125.         'La procédure enregistre le numéro de ligne correspondant dans un tableau.
  126.         If Err.Number <> 0 Then
  127.             x = x + 1
  128.             ReDim Preserve Tableau(1 To x)
  129.             Tableau(x) = Cell.Row
  130.             Err.Clear
  131.         End If
  132.     Next Cell
  133.     On Error GoTo 0
  134.     'On sort si aucun doublon n'a été trouvé.
  135.     If x = 0 Then Exit Sub
  136.     'Fige l'écran pendant la suppression des lignes
  137.     Application.ScreenUpdating = False
  138.     'Boucle sur le tableau pour supprimer les lignes contenant des doublons.
  139.     For x = UBound(Tableau) To LBound(Tableau) Step -1
  140.         Worksheets("Feuil1" ).Rows(Tableau(x)).EntireRow.Delete
  141.     Next x
  142.     Application.ScreenUpdating = True
  143. End Sub
  144. Private Sub Traitement()
  145. Dim ligne As Integer: Dim colonne As Integer
  146. ligne = ligne_debut: colonne = colonne_debut
  147. Cells(ligne, colonne).Sort Cells(ligne, colonne), xlAscending, Header:=xlNo
  148. 'For i = Range("C65536" ).End(xlUp).Row To 2 Step -1
  149.   ' For j = i - 1 To 2 Step -1
  150.    ' If Cells(i, 1) = Cells(j, 1) Then
  151.    '    Rows(i).Delete
  152.   '  End If
  153. ' Next j
  154. 'Next i
  155. ''While Cells(ligne, colonne).Value <> ""
  156.    '' If (Cells(ligne, colonne).Value = Cells(ligne - 1, colonne).Value) Then
  157.       ''  Cells(ligne, colonne).EntireRow.Delete
  158.      ''   ligne = ligne - 1
  159.    '' End If
  160.   ''  ligne = ligne + 1
  161. ''Wend
  162.  
  163.  
  164. End Sub


Au besoin je peux vous fournir mon fichier xlsm et un fichier .txt brut
 
En vous remerciant pour votre aide ;-)
flod49

Reply

Marsh Posté le 20-04-2017 à 07:23:00   

Reply

Marsh Posté le 21-04-2017 à 18:51:46    

je vois que je donne des mots de tête aux lecteurs ^^

Reply

Marsh Posté le 21-04-2017 à 20:44:12    

 
            'soir,
 
            pas vraiment pour ceux ayant vu le multiple postage sauvage sur plusieurs forums alors ils zappent ce sujet …
 

Reply

Marsh Posté le 22-04-2017 à 06:22:16    

Marc L a écrit :

 
            'soir,
 
            pas vraiment pour ceux ayant vu le multiple postage sauvage sur plusieurs forums alors ils zappent ce sujet …
 


Rebonjour Marc-L , pour vous poster sur 2 forums c'est du "postage sauvage"??? :pt1cable:  
 

Reply

Marsh Posté le 22-04-2017 à 11:09:52    

 
            Oui à partir du moment qu'il y a plus d'un forum et sans en avoir prévenu aucun ni y avoir posté de lien vers l'autre forum ‼
            C'est très mal considéré, comme un manque de respect …
 
            Lundi sur le forum D :      ah oui j'ai vu le même post sur le forum H, je regarderai demain sur ce forum si cela a avancé …
 
            Mardi sur le forum H :      cela n'a pas avancé mais demain je verrais bien sur le forum D …
 
            Mercredi sur le forum D :  toujours pas de réponse mais bon je ne vais pas perdre de temps s'il y a une réponse sur le forum H …
 
            Jeudi sur le forum H :       on verra bien demain sur l'autre forum …
 
            Vendredi sur le forum D, la question ne se pose même pas car le post est déjà oublié en seconde page du forum !


Message édité par Marc L le 22-04-2017 à 11:11:55
Reply

Marsh Posté le 25-04-2017 à 16:29:40    

Bonjour, en évitant d’épiloguer sur ce genre de commentaire par des réponses non constructives... Et ne souhaitant pas mettre à rude épreuve la susceptibilité de certains.....
voici le post sur lequel j'ai également fait ma demande
https://www.developpez.net/forums/d [...] ost9201860
 
Et pour info, même si certain(e)s essayent de penser à ma place, sachez que je posterai la solution...
A bon entendeur....

Reply

Sujets relatifs:

Leave a Replay

Make sure you enter the(*)required information where indicate.HTML code is not allowed