XL 2019 Problème avec WorksheetFunction

msauvegrain à dit:

Bonjour,

J'ai créer une macro pour traduire certaines colonnes d'un classeur.
Cette macro est enregistrée dans perso.xlam.
Elle me permet de traduire et de concaténer des colonnes.

Sub xls_manager()
Dim factiv, fcible As String
Dim ligne, colonne, der_ligne As Integer

' création feuille Philamanager
Sheets(1).Select
factiv = "X_" & Cells(2, 36).Value
'MsgBox (factiv)
fcible = Cells(2, 36).Value
'MsgBox (fcible)
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = fcible

' remplissage des colonnes

'Pays
Sheets(factiv).Columns(2).Copy Sheets(fcible).Columns(1)
Sheets(fcible).Cells(1, 1).Value = "Pays"

der_ligne = Sheets(fcible).Cells.SpecialCells(xlCellTypeLastCell).Row + 1
'Rubrique
Sheets(factiv).Columns(4).Copy Sheets(fcible).Columns(2)
Sheets(fcible).Cells(1, 2).Value = "Rubrique"
ligne = 2
colonne = 2
While (ligne < der_ligne)
If Sheets(fcible).Cells(ligne, colonne) <> "" Then
If Sheets(fcible).Cells(ligne, colonne).Value = "Timbre ordinaire" Or Sheets(fcible).Cells(ligne, colonne).Value = "demi-postal" Or Sheets(fcible).Cells(ligne, colonne).Value = "Commémorative" Then
Sheets(fcible).Cells(ligne, colonne).Value = "Poste"
End If
End If
ligne = ligne + 1
Wend
ligne = 2
colonne = 2
While (ligne < der_ligne)
If Sheets(fcible).Cells(ligne, colonne) <> "" Then
If Sheets(fcible).Cells(ligne, colonne).Value = "Timbre-taxe" Then
Sheets(fcible).Cells(ligne, colonne).Value = "Taxe"
End If
End If
ligne = ligne + 1
Wend
ligne = 2
colonne = 2
While (ligne < der_ligne)
If Sheets(fcible).Cells(ligne, colonne) <> "" Then
If Sheets(fcible).Cells(ligne, colonne).Value = "Militaire" Then
Sheets(fcible).Cells(ligne, colonne).Value = "Franchise militaire"
End If
End If
ligne = ligne + 1
Wend
ligne = 2
colonne = 2
While (ligne < der_ligne)
If Sheets(fcible).Cells(ligne, colonne) <> "" Then
If Sheets(fcible).Cells(ligne, colonne).Value = "Autres" Then
Sheets(fcible).Cells(ligne, colonne).Value = "Divers"
End If
End If
ligne = ligne + 1
Wend
ligne = 2
colonne = 2
While (ligne < der_ligne)
If Sheets(fcible).Cells(ligne, colonne) <> "" Then
If Sheets(fcible).Cells(ligne, colonne).Value = "Poste aérienne mi-postale" Then
Sheets(fcible).Cells(ligne, colonne).Value = "Poste aérienne"
End If
End If
ligne = ligne + 1
Wend

'N° YT
Sheets(factiv).Columns(30).Copy Sheets(fcible).Columns(3)
Sheets(fcible).Cells(1, 3).Value = "N°"

'Année
Sheets(factiv).Columns(3).Copy Sheets(fcible).Columns(4)
Sheets(fcible).Cells(1, 4).Value = "Année"

'Désignation
Dim designation, description, papier, filigrane, michel, scott, stanley, largeur, hauteur, remarque, desgn As String
Dim texte0, texte1, origine, destination, URL, HTML, balisedebut, positiondepart, positionfin As String
origine = "en"
destination = "fr"
balisedebut = "<div class=""result-container"">"
Sheets(fcible).Cells(1, 5).Value = "Désignation"

Sheets(factiv).Columns(5).Copy Sheets(fcible).Columns(40) 'Désignation
ligne = 2
While (ligne < der_ligne)
texte0 = Sheets(fcible).Cells(ligne, 40).Value
URL = "https://translate.google.com/m?sl=" & origine & "&tl=" & destination & " &q=" & WorksheetFunction.EncodeURL(texte0)
HTML = WorksheetFunction.WebService(URL)
Application.Wait (Now + TimeValue("0:00:01"))
positiondepart = InStr(HTML, balisedebut)
positionfin = InStr(positiondepart, HTML, "</div>")
texte1 = Mid(HTML, positiondepart, positionfin - positiondepart)
texte1 = Replace(texte1, balisedebut, "")
Sheets(fcible).Cells(ligne, 40).Value = texte1
ligne = ligne + 1
Wend
Sheets(factiv).Columns(10).Copy Sheets(fcible).Columns(41) 'Description
ligne = 2
While (ligne < der_ligne)
texte0 = Sheets(fcible).Cells(ligne, 41).Value
URL = "https://translate.google.com/m?sl=" & origine & "&tl=" & destination & " &q=" & WorksheetFunction.EncodeURL(texte0)
HTML = WorksheetFunction.WebService(URL)
positiondepart = InStr(HTML, balisedebut)
positionfin = InStr(positiondepart, HTML, "</div>")
texte1 = Mid(HTML, positiondepart, positionfin - positiondepart)
texte1 = Replace(texte1, balisedebut, "")
Sheets(fcible).Cells(ligne, 41).Value = texte1
ligne = ligne + 1
Wend
Sheets(factiv).Columns(13).Copy Sheets(fcible).Columns(42) 'Papier
ligne = 2
While (ligne < der_ligne)
texte0 = Sheets(fcible).Cells(ligne, 42).Value
URL = "https://translate.google.com/m?sl=" & origine & "&tl=" & destination & " &q=" & WorksheetFunction.EncodeURL(texte0)
HTML = WorksheetFunction.WebService(URL)
positiondepart = InStr(HTML, balisedebut)
positionfin = InStr(positiondepart, HTML, "</div>")
texte1 = Mid(HTML, positiondepart, positionfin - positiondepart)
texte1 = Replace(texte1, balisedebut, "")
Sheets(fcible).Cells(ligne, 42).Value = texte1
ligne = ligne + 1
Wend
Sheets(factiv).Columns(14).Copy Sheets(fcible).Columns(43) 'Filigrane
ligne = 2
While (ligne < der_ligne)
texte0 = Sheets(fcible).Cells(ligne, 43).Value
URL = "https://translate.google.com/m?sl=" & origine & "&tl=" & destination & " &q=" & WorksheetFunction.EncodeURL(texte0)
HTML = WorksheetFunction.WebService(URL)
positiondepart = InStr(HTML, balisedebut)
positionfin = InStr(positiondepart, HTML, "</div>")
texte1 = Mid(HTML, positiondepart, positionfin - positiondepart)
texte1 = Replace(texte1, balisedebut, "")
Sheets(fcible).Cells(ligne, 43).Value = texte1
ligne = ligne + 1
Wend
Sheets(factiv).Columns(31).Copy Sheets(fcible).Columns(44) 'N° Michel
Sheets(factiv).Columns(11).Copy Sheets(fcible).Columns(45) 'Largeur
Sheets(factiv).Columns(12).Copy Sheets(fcible).Columns(46) 'Hauteur
Sheets(factiv).Columns(28).Copy Sheets(fcible).Columns(47) 'Remarque
ligne = 2
While (ligne < der_ligne)
texte0 = Sheets(fcible).Cells(ligne, 47).Value
URL = "https://translate.google.com/m?sl=" & origine & "&tl=" & destination & " &q=" & WorksheetFunction.EncodeURL(texte0)
HTML = WorksheetFunction.WebService(URL)
positiondepart = InStr(HTML, balisedebut)
positionfin = InStr(positiondepart, HTML, "</div>")
texte1 = Mid(HTML, positiondepart, positionfin - positiondepart)
texte1 = Replace(texte1, balisedebut, "")
Sheets(fcible).Cells(ligne, 47).Value = texte1
ligne = ligne + 1
Wend
Sheets(factiv).Columns(32).Copy Sheets(fcible).Columns(48) 'N° Scott
Sheets(factiv).Columns(38).Copy Sheets(fcible).Columns(49) 'N° Stanley

ligne = 2
While (ligne < der_ligne)
designation = Sheets(fcible).Cells(ligne, 40).Value
If Sheets(fcible).Cells(ligne, 41).Value <> "NR" Then
description = " , " & Sheets(fcible).Cells(ligne, 41).Value
Else
description = ""
End If
If Sheets(fcible).Cells(ligne, 42).Value <> "NR" Then
papier = "Papier : " & Sheets(fcible).Cells(ligne, 42).Value
Else
papier = ""
End If
If Sheets(fcible).Cells(ligne, 43).Value <> "NR" Then
If papier <> "" Then
filigrane = " , " & Sheets(fcible).Cells(ligne, 43).Value
Else
filigrane = "Filigrane : " & Sheets(fcible).Cells(ligne, 43).Value
End If
Else
filigrane = ""
End If
michel = "N° Michel : " & Sheets(fcible).Cells(ligne, 44).Value
If Sheets(fcible).Cells(ligne, 48).Value <> "NR" Then
scott = ", N° Scott : " & Sheets(fcible).Cells(ligne, 48).Value
Else
scott = ""
End If
If Sheets(fcible).Cells(ligne, 49).Value <> "NR" Then
stanley = ", N° Stanley : " & Sheets(fcible).Cells(ligne, 49).Value
Else
stanley = ""
End If
If Sheets(fcible).Cells(ligne, 45).Value <> 0 Then
largeur = ", Largeur : " & Sheets(fcible).Cells(ligne, 45).Value
Else
largeur = ""
End If
If Sheets(fcible).Cells(ligne, 46).Value <> 0 Then
hauteur = ", Hauteur : " & Sheets(fcible).Cells(ligne, 46).Value
Else
hauteur = ""
End If
If Sheets(fcible).Cells(ligne, 47).Value <> "NR" Then
remarque = Chr(13) & "Remarque : " & Sheets(fcible).Cells(ligne, 47).Value
Else
remarque = ""
End If
desgn = designation & description & Chr(13) & papier & filigrane & largeur & hauteur & Chr(13) & michel & scott & stanley & Chr(13) & remarque
desgn = Replace(desgn, "&quot;", """")
desgn = Replace(desgn, "&#39;", "'")
Sheets(fcible).Cells(ligne, 5).Value = desgn
ligne = ligne + 1
Wend
Sheets(fcible).Columns(5).AutoFit

Sheets(fcible).Columns(49).Delete
Sheets(fcible).Columns(48).Delete
Sheets(fcible).Columns(47).Delete
Sheets(fcible).Columns(46).Delete
Sheets(fcible).Columns(45).Delete
Sheets(fcible).Columns(44).Delete
Sheets(fcible).Columns(43).Delete
Sheets(fcible).Columns(42).Delete
Sheets(fcible).Columns(41).Delete
Sheets(fcible).Columns(40).Delete

'Faciale
Dim fac_num, fac_monnaie As String
Sheets(factiv).Columns(7).Copy Sheets(fcible).Columns(40) ' Valeur numérique
Sheets(factiv).Columns(8).Copy Sheets(fcible).Columns(41) ' Monnaie
Sheets(fcible).Cells(1, 6).Value = "Faciale"

ligne = 2
While (ligne < der_ligne)
fac_num = Sheets(fcible).Cells(ligne, 40).Value
fac_monnaie = Sheets(fcible).Cells(ligne, 41).Value
Sheets(fcible).Cells(ligne, 6).Value = fac_num & " " & fac_monnaie
ligne = ligne + 1
Wend
Sheets(fcible).Columns(6).AutoFit
Sheets(fcible).Columns(41).Delete
Sheets(fcible).Columns(40).Delete

'Tirage
Sheets(factiv).Columns(27).Copy Sheets(fcible).Columns(7)
ligne = 2
While (ligne < der_ligne)
If Sheets(fcible).Cells(ligne, 7).Value = 0 Then
Sheets(fcible).Cells(ligne, 7).Value = ""
End If
ligne = ligne + 1
Wend
Sheets(fcible).Cells(1, 7).Value = "Tirage"
Sheets(fcible).Columns(7).AutoFit

'Parution
Sheets(factiv).Columns(25).Copy Sheets(fcible).Columns(8)
ligne = 2
While (ligne < der_ligne)
If Sheets(fcible).Cells(ligne, 8).Value = "NR" Then
Sheets(fcible).Cells(ligne, 8).Value = ""
End If
ligne = ligne + 1
Wend
Sheets(fcible).Cells(1, 8).Value = "Parution"

'Retrait
Sheets(factiv).Columns(26).Copy Sheets(fcible).Columns(9)
ligne = 2
While (ligne < der_ligne)
If Sheets(fcible).Cells(ligne, 9).Value = "NR" Then
Sheets(fcible).Cells(ligne, 9).Value = ""
End If
ligne = ligne + 1
Wend
Sheets(fcible).Cells(1, 9).Value = "Retrait"

'Impression
Sheets(factiv).Columns(16).Copy Sheets(fcible).Columns(10)
ligne = 2
While (ligne < der_ligne)
If Sheets(fcible).Cells(ligne, 10).Value = "NR" Then
Sheets(fcible).Cells(ligne, 10).Value = ""
End If
ligne = ligne + 1
Wend
Sheets(fcible).Cells(1, 10).Value = "Impression"

'Dents
Sheets(factiv).Columns(15).Copy Sheets(fcible).Columns(11)
ligne = 2
While (ligne < der_ligne)
If Sheets(fcible).Cells(ligne, 11).Value = "NR" Then
Sheets(fcible).Cells(ligne, 11).Value = ""
End If
ligne = ligne + 1
Wend
Sheets(fcible).Cells(1, 11).Value = "Dents"
Sheets(fcible).Columns(11).AutoFit

'Couleur
Sheets(factiv).Columns(9).Copy Sheets(fcible).Columns(12)
ligne = 2
While (ligne < der_ligne)
If Sheets(fcible).Cells(ligne, 12).Value = "NR" Then
Sheets(fcible).Cells(ligne, 12).Value = ""
End If
ligne = ligne + 1
Wend
Sheets(fcible).Cells(1, 12).Value = "Couleur"
Sheets(fcible).Columns(12).AutoFit

'Graveur
Sheets(factiv).Columns(20).Copy Sheets(fcible).Columns(13)
ligne = 2
While (ligne < der_ligne)
If Sheets(fcible).Cells(ligne, 13).Value = "NR" Then
Sheets(fcible).Cells(ligne, 13).Value = ""
End If
ligne = ligne + 1
Wend
Sheets(fcible).Cells(1, 13).Value = "Graveur"
Sheets(fcible).Columns(13).AutoFit

'Cotes
Sheets(fcible).Cells(1, 14).Value = "Cote neuf"
Sheets(fcible).Cells(1, 15).Value = "Cote charn"
Sheets(fcible).Cells(1, 16).Value = "Cote obli"
Sheets(fcible).Cells(1, 17).Value = "Cote autre"
Sheets(fcible).Cells(1, 19).Value = "Variante"
Sheets(fcible).Cells(1, 20).Value = "Autocollant"

'Thème
Sheets(factiv).Columns(24).Copy Sheets(fcible).Columns(18)
Sheets(fcible).Cells(1, 18).Value = "Thème"

'Dessinateur
Sheets(factiv).Columns(19).Copy Sheets(fcible).Columns(21)
ligne = 2
While (ligne < der_ligne)
If Sheets(fcible).Cells(ligne, 21).Value = "NR" Then
Sheets(fcible).Cells(ligne, 21).Value = ""
End If
ligne = ligne + 1
Wend
Sheets(fcible).Cells(1, 21).Value = "Dessinateur"
Sheets(fcible).Columns(21).AutoFit


Dim sh As Worksheet
Set sh = Sheets(1)
Application.DisplayAlerts = False
sh.Delete
Sheets(factiv).Delete
Application.DisplayAlerts = True

Sheets(fcible).Cells(1, 1).Select

End Sub

Elle est activée par un bouton dans les actions rapides.

Mon problème est qu'elle bloque de temps en temps sur WorksheetFunction

Ci-joint deux fichiers test.

Le .xlsm est la source et le .xls est le rendu après la macro.

Impossible de procéder à la macro sur le fichier RDA.

Merci de vos conseils.

@+, Michel

Cliquez pour agrandir...