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
  5. Private Sub exporter_Click()
  6. Dim nom_fichier As String
  7. ligne_debut = 2: colonne_debut = 2
  8. ligne_enCours = ligne_debut: colonne_enCours = colonne_debut
  10. Cells.Clear
  12. For i = 0 To liste_fichiers.ListCount - 1
  13.     lecture (liste_fichiers.List(i))
  14. Next i
  16. Traitement
  17. nom_fichier = Application.GetSaveAsFilename(fileFilter:="Text Files (*.txt),*.txt" )
  18. sortie.Value = nom_fichier
  19. ecriture (nom_fichier)
  22. End Sub
  24. Private Sub fermer_Click()
  25. liste_fichiers.Clear
  26. formulaire.Hide
  29. End Sub
  32. Private Sub importer_Click()
  33. Dim fichier_choisi As String
  35. fichier_choisi = Application.GetOpenFilename("Text Files (*.txt),*.txt", , "Sélectionner le fichier CSV" )
  37. If (LCase(fichier_choisi) <> "faux" And fichier_choisi <> "0" ) Then
  38.     liste_fichiers.AddItem (fichier_choisi)
  39. End If
  41. End Sub
  44. Private Sub liste_fichiers_Click()
  46. End Sub
  48. Private Sub modifier_texte_Click()
  49. Dim str As String
  50. Dim fso As FileSystemObject ' AJOUTER LA REFERENCE (VOIR FAQ SI BESOIN)
  51. Dim fs As Folder
  52. Dim ts As TextStream
  53. Dim pathaouvrir As Variant
  55. Set fso = New FileSystemObject
  56. ' ouvre le fichier
  57. Set fs = fso.GetFolder("D:\tintintitn\lalalala\" )
  58. pathaouvrir = Application.GetOpenFilename("Text Files (*.txt),*.txt", , "Sélectionner le fichier CSV" )
  59.     If pathaouvrir <> False Then
  60.     'vérifions toujours que le fichier existe
  61.     If Dir(pathaouvrir) <> "" Then
  62.     Set ts = fso.OpenTextFile(pathaouvrir)
  63.     ' met tout le contenu dans une variable
  64.         str = ts.ReadAll
  65.         ts.Close
  66.     ' remplace
  67.     str = Replace(str, "C1H1=", "C1;H1 = " )
  68.     ' on écrase
  69.     Set ts = fso.createtextfile(pathaouvrir, True)
  70.         ts.write str
  71.         ts.Close
  72. End If
  73. End Sub
  75. Private Sub sortie_Change()
  77. End Sub
  79. Private Sub UserForm_Click()
  81. End Sub
  83. Private Sub lecture(Fichier As String)
  84. Dim depart As Integer, position As Integer
  85. Dim texte As String, tampon As String
  88. Open Fichier For Input As #1
  90. Do While Not EOF(1)
  91.     Line Input #1, texte
  92.     depart = 1: position = 1
  93.     Do While (position <> 0)
  94.         position = InStr(depart, texte, ";", 1)
  95.         If position = 0 Then
  96.             tampon = Mid(texte, depart)
  97.             Sheets("Import" ).Cells(ligne_enCours, colonne_enCours).Value = tampon
  98.             Exit Do
  99.         Else
  100.             tampon = Mid(texte, depart, position - depart)
  101.         End If
  102.        
  103.         Sheets("Import" ).Cells(ligne_enCours, colonne_enCours).Value = tampon
  104.         depart = position + 1
  105.         colonne_enCours = colonne_enCours + 1
  106.        
  107.     Loop
  108.    
  109.     colonne_enCours = colonne_debut
  110.     ligne_enCours = ligne_enCours + 1
  111.    
  113. Loop
  115. Close #1
  118. End Sub
  119. Private Sub ecriture(Fichier As String)
  121. Dim ligne As Integer, colonne As Integer
  122. Dim texte As String
  123. ligne = ligne_debut: colonne = colonne_debut
  125. If LCase(Fichier) <> "faux" Then
  126. Open Fichier For Output As #1
  128.     While Cells(ligne, colonne).Value <> ""
  129.         While Cells(ligne, colonne).Value <> ""
  130.             texte = texte & Cells(ligne, colonne).Value & ";"
  131.                                  
  132.             colonne = colonne + 1
  133.         Wend
  134.         Print #1, texte
  135.         texte = ""
  136.         colonne = colonne_debut
  137.         ligne = ligne + 1
  138.        
  139.        
  140.     Wend
  141.    
  142.    
  143. Close #1
  145. End If
  147. End Sub
  149. Sub SupprimeDoublons()
  150.     Dim Plage As Range, Cell As Range
  151.     Dim Un As New Collection
  152.     Dim Tableau() As Integer
  153.     Dim x As Integer
  156.     'Définit la plage de cellules pour la recherche de doublons
  157.     Set Plage = Worksheets("Import" ).Range("c2:c99999" )
  159.     On Error Resume Next
  160.     'Boucle sur les cellules de la plage cible
  161.     For Each Cell In Plage
  162.         'Création d'une collection de données uniques (sans doublons)
  163.         Un.Add Cell, CStr(Cell)
  165.         'Une erreur survient si l'élément existe dans la collection.
  166.         'La procédure enregistre le numéro de ligne correspondant dans un tableau.
  167.         If Err.Number <> 0 Then
  168.             x = x + 1
  169.             ReDim Preserve Tableau(1 To x)
  170.             Tableau(x) = Cell.Row
  171.             Err.Clear
  172.         End If
  173.     Next Cell
  174.     On Error GoTo 0
  176.     'On sort si aucun doublon n'a été trouvé.
  177.     If x = 0 Then Exit Sub
  179.     'Fige l'écran pendant la suppression des lignes
  180.     Application.ScreenUpdating = False
  182.     'Boucle sur le tableau pour supprimer les lignes contenant des doublons.
  183.     For x = UBound(Tableau) To LBound(Tableau) Step -1
  184.         Worksheets("Feuil1" ).Rows(Tableau(x)).EntireRow.Delete
  185.     Next x
  187.     Application.ScreenUpdating = True
  188. End Sub
  191. Private Sub Traitement()
  192. Dim ligne As Integer: Dim colonne As Integer
  193. ligne = ligne_debut: colonne = colonne_debut
  195. Cells(ligne, colonne).Sort Cells(ligne, colonne), xlAscending, Header:=xlNo
  197. 'For i = Range("C65536" ).End(xlUp).Row To 2 Step -1
  198.   ' For j = i - 1 To 2 Step -1
  199.    ' If Cells(i, 1) = Cells(j, 1) Then
  200.    '    Rows(i).Delete
  201.   '  End If
  202. ' Next j
  203. 'Next i
  204. ''While Cells(ligne, colonne).Value <> ""
  205.    '' If (Cells(ligne, colonne).Value = Cells(ligne - 1, colonne).Value) Then
  206.       ''  Cells(ligne, colonne).EntireRow.Delete
  207.      ''   ligne = ligne - 1
  208.    '' End If
  209.   ''  ligne = ligne + 1
  210. ''Wend
  211.  
  212.  
  214. 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 …
 

Message cité 1 fois
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