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

J
  • Question
XL 2010 VBA Excel Insertion d'un paragraphe dans un doc Word
Réponses
0
Affichages
112
Jérémy26
J
B
  • Question
Microsoft 365 2 macros de copie
Réponses
9
Affichages
528
Softmama
S
F
  • Question
Microsoft 365 erreur 1004 : cette interface n'est pas prise en charge
Réponses
1
Affichages
239
Bernard_XLD
Bernard_XLD
KTM
  • Question
XL 2019 Supprimer lignes après échéance
Réponses
2
Affichages
188
KTM
KTM
J
  • Question
Copie valeurs
Réponses
4
Affichages
319
JLR67
J
B
  • Question
Microsoft 365 Colorer les Lignes coller
Réponses
4
Affichages
141
bd.afaf
B
B
  • Question
Microsoft 365 colorer une plage
Réponses
2
Affichages
154
bd.afaf
B
J
  • Résolu(e)
XL 2010 Récupérer un tableur Word sous Excel
Réponses
13
Affichages
367
Jérémy26
J
D
  • Question
XL 2013 ASTUCE VBA supprimer contenu cellule sans mise en forme ni formule
Réponses
5
Affichages
196
job75
job75
KTM
  • Question
XL 2016 rafraîchir écran
Réponses
0
Affichages
168
KTM
KTM

Membres actuellement en ligne

1 membres et 62 invités.

Partager cette page

Tutos vidéos

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
Extraire du texte d'une chaîne de caractères avec des fonctions

Statistiques des forums

Discussions
297 988
Messages
1 964 906
Membres
200 747
dernier inscrit
mtb60