XL 2016 Bug macro sur boucle FOR EACH depuis MAJ Office

[samimi94]

Bonjour le forum,

Je sollicite de nouveau votre aide suite à plusieurs recherches infructueuses.

Je rencontre un problème d’exécution d'une macro sous 2016 (pack 365) depuis la mise à jour du pack Office cette semaine.

L’exécution "pas à pas" semble indiquer que le bug se produit sur deux boucles :

 Dim x As Range
    For Each x In Selection
        x = suppAccent(x.Value)
    Next x

et

Set Plage = Intersect(Selection, ActiveSheet.UsedRange)
If Plage Is Nothing Then Exit Sub
For Each Cel In Plage
    Cel = UCase(Cel)
Next Cel

Ce problème a été décelé uniquement sous la version 2016 (365), or sur la version 2016 PC même après MAJ la macro fonctionne correctement.

En espérant que cette erreur peut-être corrigée par une simple modification de code.

Merci à tous pour votre aide.

Samimi94

 

[Staple1600]

Bonjour le fil, le forum

@samimi94
Peux-tu poster cette fontion
suppAccent

Qu'on voit à quoi elle ressemble.

 

[samimi94]

Bonjour Staple 1600,

Voici la fonction :

Function suppAccent(chaine As String) As String

    Dim accent As String, sansAccent As String, i As Long
    accent = "áàâäãåéèêëíìîïóòôöõðúùûüÿýçÀÁÂÃÄÈÉÊËÌÍÎÏÒÓÔÕÖÙÚÛÜ()-_/\+-*~'"
    sansAccent = "aaaaaaeeeeiiiioooooouuuuyycaaaaaeeeeiiiiooooouuuu           "
    For i = 1 To Len(accent)
        chaine = Replace(chaine, Mid(accent, i, 1), Mid(sansAccent, i, 1))
    Next i
    suppAccent = chaine
End Function

Merci pour ton aide.

Samimi94

 

[Staple1600]

Re

Pour tester, tu peux joindre une petit fichier Excel en guise d'exemple, stp?
(un fichier sans données confidentielles)

 

[samimi94]

Staple1600,

Mon fichier contient effectivement plusieurs données confidentielles.
J'ai créé un fichier test qui reprend la macro entière en espérant que cela puisse aider.

Merci.
Samimi94.

 

[Staple1600]

Re

Tu peux tester en remplaçant la partie suppression accent par celle-ci

'...au dessus le reste de ton code
Dim Cel As Range, Plage As Range, x As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
For Each x In ActiveSheet.UsedRange
If TypeName(x.Value) = "String" Then
x.Value = suppAccent(x.Text)
End If
Next
Columns("A:C").ColumnWidth = 30: Columns("D:D").ColumnWidth = 10
Columns("E:E").ColumnWidth = 25: Columns("F:F").ColumnWidth = 2
Application.ScreenUpdating = True
Application.EnableEvents = True
'...  en dessous le reste de ton code

et en utilisant ta fonction modifiée ainsi

Function suppAccent(chaine As String) As String
Dim accent$, sansAccent$, i&
accent = "áàâäãåéèêëíìîïóòôöõðúùûüÿýçÀÁÂÃÄÈÉÊËÌÍÎÏÒÓÔÕÖÙÚÛÜ()-_/\+-*~'"
sansAccent = "aaaaaaeeeeiiiioooooouuuuyycaaaaaeeeeiiiiooooouuuu           "
For i = 1 To Len(accent)
chaine = Replace(chaine, Mid(accent, i, 1), Mid(sansAccent, i, 1))
Next i
suppAccent = VBA.UCase(chaine)
End Function

 

[samimi94]

Staple1600, le forum,

Merci d'avoir pris le temps de te pencher sur mon problème.

J'ai recopié le code. La macro passe l'étape de la 1ère boucle for each mais bug sur la fonction à cet emplacement :

chaine = Replace(chaine, Mid(accent, i, 1), Mid(sansAccent, i, 1))
Next i

Du coup le fichier texte généré reste vide.

Merci.
Samimi94.

 

[Staple1600]

Re

en remplaçant la partie suppression accent par celle-ci

Ce qui sous-entend que mes modifications ne concernent que la suppression des accents

Testes uniquement cette partie (en mettant en commentaire la partie du code qui génère le fichier)

Est-ce que les accents sont bien supprimés sur la feuille Excel ?[/quote][/quote]

 

[samimi94]

Staple1600,

J'ai bien supprimé que la partie qui concerne les accents.
Avant cela je n'arrivais pas à aller jusqu'à l'enregistrement du fichier texte car la macro avait ce bug.
Je te confirme que les accents sont bien remplacés. Pour ce point c'est OK.

La partie qui génère le fichier est la suivante :

ChDrive "C"
ChDir "C:\"
NewName = "TEST.prn" '

nmFichier = "TEST"
nmFichierSauvé = Application.GetSaveAsFilename(nmFichier, _
"Texte (séparateur: espace) (*.prn), *.prn", , _
"Export de fichiers texte")

idFichier = FreeFile()

Open nmFichierSauvé For Output As #idFichier

nbLignes = Selection.Rows.Count
nbColonnes = Selection.Columns.Count

For iLigne = 1 To nbLignes
For iColonne = 1 To nbColonnes
With Selection.Cells(iLigne, iColonne)

largCellule = Application.Round(.ColumnWidth, 0)

txtCellule = .Text

If Len(txtCellule) < largCellule Then
   Select Case .HorizontalAlignment
      Case xlGeneral, xlFill
      If Application.IsNumber(.Value) Then
         txtCellule = String(largCellule - Len(txtCellule), " ") & txtCellule
      Else
         txtCellule = txtCellule & _
         String(largCellule - Len(txtCellule), " ")
      End If
      Case xlLeft, xlJustify
      txtCellule = txtCellule & _
      String(largCellule - Len(txtCellule), " ")
   End Select
Else
   txtCellule = Left(txtCellule, largCellule)
End If

End With

Print #idFichier, txtCellule;

Next iColonne

If iLigne <> nbLignes Then Print #idFichier, ""

Next iLigne

Close #idFichier

On Error Resume Next
Kill "C:\TEST.txt"

Name "C:\TEST.prn" As "C:\TEST.txt"

Merci.
Samimi94

 

[Staple1600]

Re

Quel format doit avoir ton fichier texte?
Un simple export en *.csv ou *.txt directement ne suffirait pas ?

 

[samimi94]

Staple1600,

Un fichier texte avec séparateur espace, d'où l'enregistrement au format prn avant de le renommer en .txt

Merci.
Samimi94.

 

[samimi94]

Staple1600,

En complément de mon message précédent, Excel ouvre bien la boite d'export de fichier texte et propose bien le bon nom de fichier.
Les données en arrière plan sont bien sélectionnées et lorsque je clique sur enregistré Excel affiche la boite de dialogue qui confirme l'enregistrement puis plante complètement l'application Excel.
Le fichier texte est à 0 ko.

Merci.
Samimi94.

 

[Staple1600]

Re

Est-ce que cette macro d'export te donne un format correct de fichier texte pour tes besoins

Sub Export_TXT()
Dim fic_TXT
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveSheet.Copy
fic_TXT = Application.GetSaveAsFilename(fileFilter:="FICHIER TEXTE (*.txt), *.txt")
ActiveWorkbook.SaveAs Filename:=fic_TXT, FileFormat:=xlText, CreateBackup:=False
ActiveWorkbook.Close False
End Sub

 

[samimi94]

Staple 1600,

Le fichier texte est bien généré et il est bien alimenté, mais je n'ai plus le respect des longueurs de champs avec retour chariot.
Du coup ça ne peut pas convenir avec ce format.

Merci.
Samimi94.

 

[Staple1600]

Re,

J'ai retrouvé ceci dans mes archives
Ça semble convenir à ta problématique.
J'ai testé sur ton fichier exemple

Sub CreateFixedWidthFile(strFile As String, ws As Worksheet, s() As Integer)
'source:mark007|xpress|(nb)759
    Dim i&, j&, fNum&, strLine$, strCell$
    fNum = FreeFile
     'open the textfile
    Open strFile For Output As fNum
     'loop from first to last row
     'use 2 rather than 1 to ignore header row
    For i = 1 To ws.Range("A65536").End(xlUp).Row
         'new line
        strLine = ""
         'loop through each field
        For j = 0 To UBound(s)
             'make sure we only take chars up to length of field (may want to output some sort of error if it is longer than field)
            strCell = Left$(ws.Cells(i, j + 1).Value, s(j))
             'add on string of spaces with length equal to the difference in length between field length and value length
            strLine = strLine & strCell & String$(s(j) - Len(strCell), Chr$(32))
        Next j
         'write the line to the file
        Print #fNum, strLine
    Next i
     'close the file
    Close #fNum
End Sub
 
Sub CreateFile()
    Dim sPath As String
    sPath = Application.GetSaveAsFilename("", "Text Files,*.txt")
    If LCase$(sPath) = "false" Then Exit Sub
     'specify the widths of our fields
     'the number of columns is the number specified in the line below +1
   Dim s(6) As Integer
     'starting at 0 specify the width of each column
    s(0) = 30
    s(1) = 30
    s(2) = 30
    s(3) = 10
    s(4) = 25
    s(5) = 2
    CreateFixedWidthFile sPath, ActiveSheet, s
End Sub