réduction code bloquer par concanténation

grisan29

grisan29

XLDnaute Accro
bonjour a tous et bonne année pour 2015

je suis en cours de réduction d'un code sur un fichier de stock trouvé sur le net mais qui as du être en partie fait par l'enregistreur de macros et une partie me pose un problème
Code: 
Range("A2").Select
Sheets("Tableau_Insertion").Select
    Range("G13:H13").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("FOURNISSEUR").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("K2").Select

    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-6],"" "",RC[-5])"
    Range("A2:K2").Select
    Range("K2").Activate
c'est la 2ème partie qui gêne car je pense que la 1ère est réduite comme il faut :rolleyes:j'espère
Code: 
Worksheets("Tableau_Insertion").Range("G13:H13").Copy
ActiveSheet.Paste Destination:=Worksheets("FOURNISSEUR").Range("K2")

merci de vos conseils avisés

Pascal
 
Dernière édition:
Trier par date Trier par votes
grisan29

grisan29

XLDnaute Accro
Re : réduction code bloquer par concanténation

re bonsoir
voici le code tel que reçu, comme vous le verrez il y a du boulot, mais je voudrais savoir si ma methode citée plus haut est bonne car il y a 6 modules sur le même topo, voila qu'a même pour savoir de quoi il en tenait
Code: 
Sub Insertion_Fournisseur()
'
' Insertion_Fournisseur Macro
'

'
    Sheets("FOURNISSEUR").Select
    Rows("2:2").Select
    Selection.Insert Shift:=xlDown
    Selection.ClearFormats
    Range("A2:K2").Select
    Range("K2").Activate
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A2").Select
    Sheets("Tableau_Insertion").Select
    Range("G4:H4").Select
    Selection.Copy
    Sheets("FOURNISSEUR").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("B2").Select
    Sheets("Tableau_Insertion").Select
    Range("G5:H5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("FOURNISSEUR").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C2").Select
    Sheets("Tableau_Insertion").Select
    Range("G6:H6").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("FOURNISSEUR").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("D2").Select
    Sheets("Tableau_Insertion").Select
    Range("G7:H7").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("FOURNISSEUR").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("E2").Select
    Sheets("Tableau_Insertion").Select
    Range("G8:H8").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("FOURNISSEUR").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("F2").Select
    Sheets("Tableau_Insertion").Select
    Range("G9:H9").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("FOURNISSEUR").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("G2").Select
    Sheets("Tableau_Insertion").Select
    Range("G10:H10").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("FOURNISSEUR").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"
    Range("H2").Select
    Sheets("Tableau_Insertion").Select
    Range("G11:H11").Select
    Selection.Copy
    Sheets("FOURNISSEUR").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("H:H").ColumnWidth = 13
    Application.CutCopyMode = False
    Selection.NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"
    Range("I2").Select
    Sheets("Tableau_Insertion").Select
    Range("G12:H12").Select
    Selection.Copy
    Sheets("FOURNISSEUR").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("J2").Select
    Sheets("Tableau_Insertion").Select
    Range("G13:H13").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("FOURNISSEUR").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("K2").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-6],"" "",RC[-5])"
    Range("A2:K2").Select
    Range("K2").Activate
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Columns("B:B").Select
    ActiveWorkbook.Worksheets("FOURNISSEUR").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("FOURNISSEUR").Sort.SortFields.Add Key:=Range( _
        "B2:B4"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("FOURNISSEUR").Sort
        .SetRange Range("A1:K4")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A2").Select
    Sheets("Tableau_Insertion").Select
    Range("G4:H13").Select
    Selection.ClearContents
    Range("G4:H4").Select
    ActiveCell.FormulaR1C1 = "=NUMERO_AUTO!R[6]C[-1]"
    Range("G5:H5").Select
    Sheets("NUMERO_AUTO").Range("E10") = Sheets("NUMERO_AUTO").Range("E10") + 1
End Sub

Pascal
 
Vote positif 0 Vote négatif
Paf

Paf

XLDnaute Barbatruc
Re : réduction code bloquer par concanténation

Bonjour

la 1ère est réduite comme il faut j'espère
Code :
Worksheets("Tableau_Insertion").Range("G13:H13").Copy
ActiveSheet.Paste Destination:=Worksheets("FOURNISSEUR").Range("K2")
Cliquez pour agrandir...

on aurait pu simplifier encore un peu comme ceci:

Code: 
Worksheets("Tableau_Insertion").Range("G13:H13").Copy Worksheets("FOURNISSEUR").Range("K2")

pour la deuxième, à lire le code, on ne sait plus sur quelle feuille on est.

Qu'est ce que vous voulez faire?, avec un petit classeur pour faire des tests!

A+
 
Vote positif 0 Vote négatif
grisan29

grisan29

XLDnaute Accro
Re : réduction code bloquer par concanténation

bonsoir Paf

merci de ta réponse en fait comme tu le dit je pense qu'il manque la liaison a une feuille ce qui bloque ma réflexion vois ou j'en suis mais je te rassure ce n'est que pour ma formation personnelle que j'essaie de le faire, le classeur en lui meme je peux m'en passer
Code: 
Sub Insertion_Fournisseur()
'
' Insertion_Fournisseur Macro
'

'
    With Sheets("FOURNISSEUR")
        With .Rows("2:2")
        .Insert Shift:=xlDown
        .ClearFormats
        End With
   
    .Range("K2").Activate
        With .Range("A2:K2")
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
   
    Range("A2").Select
      
     Worksheets("Tableau_Insertion").Range("G4:H4").Copy Worksheets("FOURNISSEUR").Range("B2")
       
     Worksheets("Tableau_Insertion").Range("G5:H5").Copy Worksheets("FOURNISSEUR").Range("C2")
     
     Worksheets("Tableau_Insertion").Range("G6:H6").Copy Worksheets("FOURNISSEUR").Range("D2")
      
     Worksheets("Tableau_Insertion").Range("G7:H7").Copy Worksheets("FOURNISSEUR").Range("E2")
     
     Worksheets("Tableau_Insertion").Range("G8:H8").Copy Worksheets("FOURNISSEUR").Range("F2")
   
     Worksheets("Tableau_Insertion").Range("G9:H9").Copy Worksheets("FOURNISSEUR").Range("G2")
   
     Worksheets("Tableau_Insertion").Range("G10:H10").Copy Worksheets("FOURNISSEUR").Range("H2").NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"
   
     Worksheets("Tableau_Insertion").Range("G11:H11").Copy Worksheets("FOURNISSEUR").Range("I2").NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"
   
     Worksheets("Tableau_Insertion").Range("G12:H12").Copy Worksheets("FOURNISSEUR").Range("J2")
   
     Worksheets("Tableau_Insertion").Range("G13:H13").Copy Worksheets("FOURNISSEUR").Range("K2")

et est ce que le début est bon? s'il te plait
bon j'ai essayer le code tel quel et ça fonctionne, une fois appliquer les réductions ça ne fonctionne plus quid de l'enregistreur, bon je laisse pour ce soir

pascal
 
Dernière édition:
Vote positif 0 Vote négatif
Paf

Paf

XLDnaute Barbatruc
Re : réduction code bloquer par concanténation

Re,

j'ai essayer le code tel quel et ça fonctionne, une fois appliquer les réductions ça ne fonctionne plus
Cliquez pour agrandir...

D'accord... mais sur quelle ligne l'anomalie ? quelle erreur ?

le classeur en lui meme je peux m'en passer
Cliquez pour agrandir...
le code a été établi en fonction d'une configuration de données, si vous pouvez vous passer du classeur il m'aurait été très utile pour arriver à déchiffrer le code ou pour faire des essais .

.Range("K2").Activate inutile puisque c'est sur A2:K2 que l'on veut agir
With .Range("A2:K2")
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False

Toutes les lignes bleues sont inutiles (a priori) puisqu'elles définissent les paramètres par défaut de la plage. Avec ou sans ces lignes la plage aura la même configuration.


Worksheets("Tableau_Insertion").Range("G10:H10").Copy Worksheets("FOURNISSEUR").Range("H2").NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"

A priori on ne peut pas copier et formater en même temps; il faudrait copier puis formater la plage


Bonne suite
 
Vote positif 0 Vote négatif
grisan29

grisan29

XLDnaute Accro
Re : réduction code bloquer par concanténation

bonjour Paf et le forum

Merci de tes remarques :cool: qui ont permis de ne plus avoir de bug, je te joint le code tel qu'il est fonctionnel mais surement avec des défauts résiduels, j'ai du viré le fusionnage qui était sur la feuille et donnait des codes ("G5:H5") qui buggait a cause de ça
Code: 
Sub Insertion_Fournisseur()
'
' Insertion_Fournisseur Macro
'

'
    With Sheets("FOURNISSEUR")
        With .Rows("2:2")
        .Insert Shift:=xlDown
        .ClearFormats
        End With
        
     Worksheets("Tableau_Insertion").Range("G4").Copy Worksheets("FOURNISSEUR").Range("B2")
       
     Worksheets("Tableau_Insertion").Range("G5").Copy Worksheets("FOURNISSEUR").Range("C2")
     
     Worksheets("Tableau_Insertion").Range("G6").Copy Worksheets("FOURNISSEUR").Range("D2")
     
     Worksheets("Tableau_Insertion").Range("G7").Copy Worksheets("FOURNISSEUR").Range("E2")
     
     Worksheets("Tableau_Insertion").Range("G8").Copy Worksheets("FOURNISSEUR").Range("F2")
   
     Worksheets("Tableau_Insertion").Range("G9").Copy Worksheets("FOURNISSEUR").Range("G2")
   
     Worksheets("Tableau_Insertion").Range("G10").Copy
     Worksheets("FOURNISSEUR").Range("H2").NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"
   
     Worksheets("Tableau_Insertion").Range("G11").Copy
     Worksheets("FOURNISSEUR").Range("I2").NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"
   
     Worksheets("Tableau_Insertion").Range("G12").Copy Worksheets("FOURNISSEUR").Range("J2")
   
     Worksheets("Tableau_Insertion").Range("G13").Copy Worksheets("FOURNISSEUR").Range("K2")
     
   
    .Range("h23").FormulaR1C1 = "=CONCATENATE(RC[-6],"" "",RC[-5])"
    
   .Range("A2:K2").Borders.LineStyle = 1
   
    Columns("B:B").Select
    
   Worksheets("FOURNISSEUR").Sort.SortFields.Clear
   Worksheets("FOURNISSEUR").Sort.SortFields.Add Key:=Range( _
        "B2:B4"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With Worksheets("FOURNISSEUR").Sort
        .SetRange Range("A1:K4")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End With
    'Range("A2").Select
    With Sheets("Tableau_Insertion")
    .Range("G4:H13").ClearContents
    .Range("G4").FormulaR1C1 = "=NUMERO_AUTO!R[6]C[-1]"
    End With
    'Range("G5:H5").Select
    Sheets("NUMERO_AUTO").Range("E10") = Sheets("NUMERO_AUTO").Range("E10") + 1
  
End Sub

Pascal
 
Dernière édition:
Vote positif 0 Vote négatif
Paf

Paf

XLDnaute Barbatruc
Re : réduction code bloquer par concanténation

Re,

par rapport au code du post #6:

plutôt que de copier cellule par cellule
(Worksheets("Tableau_Insertion").Range("G4").Copy Worksheets("FOURNISSEUR").Range("B2")
on peut écrire:
Worksheets("Tableau_Insertion").Range("G4:G13").Copy Worksheets("FOURNISSEUR").Range("B2")

pour ces deux lignes :
Worksheets("Tableau_Insertion").Range("G10").Copy
Worksheets("FOURNISSEUR").Range("H2").NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"

tel que c'est écrit on met en mémoire C10 d'une feuille, on formate H2 d'une autre , mais on ne copie C10 nulle part ( idem pour les deux lignes suivantes)

Bonne suite
 
Vote positif 0 Vote négatif
S

Si...

XLDnaute Barbatruc
Re : réduction code bloquer par concanténation

Salut
Paf à dit:
Worksheets("Tableau_Insertion").Range("G4:G13").Copy Worksheets("FOURNISSEUR").Range("B2")
Cliquez pour agrandir...

sauf s'il faut transposer. Dans ce cas tester, dans la page de code de Tableau_Insertion
Code: 
Sub Insertion_Fournisseur()
  With Sheets("FOURNISSEUR")
    With .Rows(2)
      .Insert Shift:=xlDown
      .ClearFormats
    End With
    .[B2:K2] = Application.Transpose([G4:G13])
    .[H2:I2].NumberFormat = "0#"" ""##"" ""##"" ""##"" ""##"
    .[H23].FormulaR1C1 = "=CONCATENATE(RC[-6],"" "",RC[-5])"   '???
    .[A2:K2].Borders.LineStyle = 1
    .[B2:B65000].Sort .[B2], 1
    [G4:H13] = ""
    Range("G4").FormulaR1C1 = "=NUMERO_AUTO!R[6]C[-1]"
  End With
  Sheets("NUMERO_AUTO").Range("E10") = Sheets("NUMERO_AUTO").Range("E10") + 1
End Sub
 
Vote positif 0 Vote négatif
grisan29

grisan29

XLDnaute Accro
Re : réduction code bloquer par concanténation

bonsoir Paf et Si...
si.... le code que tu propose remplace le long code que j'ai mis en post 2?? si c'est le cas waouh c:cool:a c'est de la réduction:cool:
et j'ai fait un test réussi :cool::cool::cool:
je vais voir si je peux faire autant( pas gagné ça) avec les autres modules je ne ferme pas au cas où

Pascal
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

R
  • Résolu(e)
XL 2019 creer une macro pour copier des info d un onglet a un autre dans le meme classeur
Réponses
4
Affichages
281
robpellan52
R
S
  • Résolu(e)
Autres ActiveWorkbook.Worksheets("vierge").AutoFilter.Sort.SortFields.Clear
2
Réponses
23
Affichages
1 K
AtTheOne
AtTheOne
O
  • Question
XL 2010 aide sur code VBA collationnement de données
Réponses
10
Affichages
461
olivier388
O
mouchtre
  • Résolu(e)
Microsoft 365 Macro fonctionnant avec excel 365 sur windows 11 mais ne fonctionnent pas sur un autre windows 11 avec aussi un excel 365
Réponses
11
Affichages
535
mouchtre
mouchtre
K
  • Question
XL 2019 Organiser le code VBA
Réponses
9
Affichages
578
Kevin38
K
M
  • Résolu(e)
XL 2016 Filtre auto VBA
Réponses
3
Affichages
591
MickaeL_D
M
M
  • Question
XL 2013 Envoyer un mail automatique avec le contenu de la bonne ligne
Réponses
2
Affichages
652
Oneida
Oneida
A
  • Résolu(e)
XL 2013 Code VBA incompatible avec version Excel
Réponses
2
Affichages
402
Averell1976
A
R
  • Question
Microsoft 365 Ecraser onglet par copier coller [RESOLU]
Réponses
4
Affichages
305
romubzh35
R
B
  • Résolu(e)
XL 2016 macro avec boucle
2
Réponses
16
Affichages
1 K
benbella1991
B

Membres actuellement en ligne

15 membres et 88 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 322
Messages
2 087 274
Membres
103 503
dernier inscrit
maison