XL 2019 Problème avec WorksheetFunction

msauvegrain

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
Trier par date Trier par votes
msauvegrain

msauvegrain

XLDnaute Nouveau
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...
Le Fichier rendu doit être enregistré en .xls pour pouvoir êttre incorporé dans PhilaManager.
 
Vote positif 0 Vote négatif

Discussions similaires

S
  • Résolu(e)
Microsoft 365 Ecrasement d'une ligne si déjà existante
Réponses
2
Affichages
116
sebastien176
S
N
  • Résolu(e)
XL 2021 comment faire recherche dans une colonne et ligne
Réponses
5
Affichages
323
job75
job75
C
  • Question
XL 2021 Problème de remplissage d'une colonne conditionné à d'autres valeurs
Réponses
2
Affichages
322
CathyLD
C
Jojo973
  • Question
Microsoft 365 Trier des données et les afficher sur une autre feuille
Réponses
10
Affichages
342
Jojo973
Jojo973
T
  • Résolu(e)
XL 2016 macro et feuille protégé
2
Réponses
18
Affichages
506
laurent950
laurent950
G
  • Résolu(e)
XL 2010 Obliger la validation d'un bouton d'option.
Réponses
8
Affichages
300
gillesda
G
G
  • Résolu(e)
XL 2021 VBA dates au mauvais format
Réponses
5
Affichages
216
vgendron
vgendron
P
  • Résolu(e)
XL 2013 EXCEL VBA
Réponses
2
Affichages
302
pangasoul
P
L
  • Question
VBA : erreur sur boucle
Réponses
2
Affichages
261
Latias
L
S
  • Résolu(e)
Microsoft 365 Récupérer la date dans un calendrier
Réponses
2
Affichages
336
sebastien176
S

Membres actuellement en ligne

18 membres et 372 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 698
Messages
2 111 998
Membres
111 386
dernier inscrit
ltitia.david