Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2019 Problème avec WorksheetFunction

msauvegrain

XLDnaute Nouveau
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
 

Pièces jointes

  • X_Allenstein.xlsm
    71.2 KB · Affichages: 2
  • X_Allenstein.xls
    154.5 KB · Affichages: 1
  • Allemagne_République_démocratique1949-1990.xlsm
    868.4 KB · Affichages: 1

msauvegrain

XLDnaute Nouveau
Le Fichier rendu doit être enregistré en .xls pour pouvoir êttre incorporé dans PhilaManager.
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…