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

L
  • Question
VBA : erreur sur boucle
Réponses
2
Affichages
63
Latias
L
S
  • Résolu(e)
Microsoft 365 Récupérer la date dans un calendrier
Réponses
2
Affichages
91
sebastien176
S
E
  • Résolu(e)
XL 2019 inserer une valeur textbox dans la dernière cellule vide horizontalement
Réponses
7
Affichages
300
escudo
E
A
  • Résolu(e)
XL 2016 Alimentation d'un fichier selon données sélectionnées via une ComboBox
Réponses
3
Affichages
295
Aldonanou
A
_l_ours
  • Résolu(e)
XL 2016 Macro Dim c As Range, i As Long
Réponses
8
Affichages
218
mapomme
mapomme
C
  • Résolu(e)
XL 2021 Remplir données devis en vba avec descriptions/quantités/PUs alignés
2
Réponses
18
Affichages
437
Phil69970
Phil69970
R
  • Question
XL 2016 excel 2016 VBA
Réponses
2
Affichages
150
rebatte
R
V
  • Résolu(e)
XL 2016 Facturier : Retour à la ligne sur la facture
2
Réponses
19
Affichages
544
Vermithor
V
D
  • Question
XL 2010 suppression de lignes dans un fichier EXCEL via une routine en VBA
Réponses
2
Affichages
240
mapomme
mapomme
B
  • Question
XL 2013 Comment trier les nom des feuilles et fusionner leur tableaux dans une une autre feuille ?
Réponses
10
Affichages
203
Compte Supprimé 979
C

Membres actuellement en ligne

13 membres et 97 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
312 104
Messages
2 085 346
Membres
102 868
dernier inscrit
JJV