Simplifier un code

maval

XLDnaute Barbatruc
Bonjour,

Voila j'ai un classeur avec une feuille "Trie"ou se trouve une centaine d'équipes de belote, une autre feuille "Feuille de marque" ou l'on rempli les feuilles des équipes (voir fichier joint).
J'ai un code qui fonctionne très bien, qui me permet de remplir cet dernier mais j'aimerai simplifier mon code car j'ai plus de cents équipes et je trouve mon code un peut lourd a mon gout.
Voir le code pour 6 équipes:
Code:
' Copie vers feuille de marque
Private Sub CommandButton1_Click()

 Sheets("Feuille de marque").Select ' Aller a la feuille marque
 Selection.Font.ColorIndex = 1
      Selection.Font.Bold = True
    Selection.Font.Italic = True
       Selection.Font.Size = 16
     
 'Table
Worksheets("Trie").Range("H3").Copy
Worksheets("Feuille de marque").Range("D2").PasteSpecial xlPasteValues  '1
Worksheets("Trie").Range("H5").Copy
Worksheets("Feuille de marque").Range("D27").PasteSpecial xlPasteValues  '2
Worksheets("Trie").Range("H7").Copy
Worksheets("Feuille de marque").Range("D52").PasteSpecial xlPasteValues  '3

' N° de la Partie
Worksheets("Trie").Range("I3").Copy
Worksheets("Feuille de marque").Range("E3").PasteSpecial xlPasteValues '1
Worksheets("Trie").Range("I3").Copy
Worksheets("Feuille de marque").Range("E28").PasteSpecial xlPasteValues '2
Worksheets("Trie").Range("I3").Copy
Worksheets("Feuille de marque").Range("E53").PasteSpecial xlPasteValues '3

'N°d'équipes
Worksheets("Trie").Range("F3").Copy 'Equipe 1
Worksheets("Feuille de marque").Range("E5").PasteSpecial xlPasteValues '1
Worksheets("Trie").Range("F4").Copy 'Equipe 2
Worksheets("Feuille de marque").Range("J5").PasteSpecial xlPasteValues '1
Worksheets("Trie").Range("F5").Copy 'Equipe 1
Worksheets("Feuille de marque").Range("E30").PasteSpecial xlPasteValues '2
Worksheets("Trie").Range("F6").Copy 'Equipe 2
Worksheets("Feuille de marque").Range("J30").PasteSpecial xlPasteValues '2
Worksheets("Trie").Range("F7").Copy 'Equipe 1
Worksheets("Feuille de marque").Range("E55").PasteSpecial xlPasteValues '3
Worksheets("Trie").Range("F8").Copy 'Equipe 2
Worksheets("Feuille de marque").Range("J55").PasteSpecial xlPasteValues '3

'Nom
Worksheets("Trie").Range("G3").Copy Worksheets("Feuille de marque").Range("D4:F4")  'Equipe 1
Worksheets("Trie").Range("G4").Copy Worksheets("Feuille de marque").Range("I4:K4") 'Equipe 2
Worksheets("Trie").Range("G5").Copy Worksheets("Feuille de marque").Range("D29:F29") 'Equipe 1
Worksheets("Trie").Range("G6").Copy Worksheets("Feuille de marque").Range("I29:K29") 'Equipe 2
Worksheets("Trie").Range("G7").Copy Worksheets("Feuille de marque").Range("D54:F54") 'Equipe 1
Worksheets("Trie").Range("G8").Copy Worksheets("Feuille de marque").Range("I54:K54") 'Equipe 2

 'sélectionne une autre cellule
Sheets("Feuille de marque").Range("L3").Select
End Sub
Merci de votre aide

Cordialement

Maval
 

Pièces jointes

  • copie_vers.xlsm
    39.7 KB · Affichages: 42
  • copie_vers.xlsm
    39.7 KB · Affichages: 42
  • copie_vers.xlsm
    39.7 KB · Affichages: 43

Gardien de phare

XLDnaute Accro
Re : Simplifier un code

Bonjour,

Sous réserve d'avoir bien compris, testes le code qui suit...
VB:
' Copie vers feuille de Points
Sub test()
Dim Wt As Worksheet, Dd As Long, i As Long
Set Wt = Worksheets("Trie")
Dd = 2
With Sheets("Feuille de marque")
For i = 3 To 121 Step 2
Debug.Print i; Dd
.Range("D" & Dd) = Wt.Range("H" & i)            'Table
.Range("E" & Dd + 1) = Wt.Range("I3")            'N° de la Partie
.Range("E" & Dd + 3) = Wt.Range("F" & i)         'N°d'équipes
.Range("J" & Dd + 3) = Wt.Range("F" & i + 1)
.Range("D" & Dd + 2) = Wt.Range("G" & i)          'Nom
.Range("I" & Dd + 2) = Wt.Range("G" & i + 1)
Dd = Dd + 25
Next
End With
End Sub

HTH
 

maval

XLDnaute Barbatruc
Re : Simplifier un code

Bonjour Fanfan, François L

François exactement la recherche nickel je me voyer mal copier toute les lignes que j'avais je te remercie beaucoup.
Si je peut abuser de ton temps dans le même style de code, aurai tu un code pour effacer toute les valeurs sur les même cellules que l'on vient de rentrer?

Mon code pour effacer.
Code:
Private Sub CommandButton1_Click()

   Union(Range("E1,J1,C3:J5,E19,J19,C21:J23,E37,J37,C39:J41,E55,J55,C57:J59,E73,J73,C75:J77,E91,J91,C93:J95,E109,J109,C111:J113,E127,J127,C129:J131,E145,J145,C147:J149,E163,J163,C165:J167,E181,J181,C183:J185,E199,J199,C201:J203,E217,J217,C219:J221,E235,J235,C237:J239"), _
    Range("E253,J253,C255:J257,E271,J271,C273:J275,E289,J289,C291:J293,E307,J307,C309:J311,E325,J325,C327:J329,E343,J343,C345:J347,E361,J361,C363:J365,E379,J379,C381:J383,E397,J397,C399:J401,E415,J415,C417:J419,E433,J433,C435:J437")).ClearContents
'sélectionne une autre cellule
Range("L2").Select

End Sub

Merci beaucoup et bonne journée

Max
 
Dernière édition:

maval

XLDnaute Barbatruc
Re : Simplifier un code

Re,

Le code que tu as fait prends les valeurs de la feuille "TRIE" et les copie sur la "FEUILLE DE MARQUES"

Maintenant il faut effacer les mêmes cellules de la "FEUILLE DE MARQUES"pour remettre la feuille comme modèle.

Je joint un exemple

@+
Max
 

Pièces jointes

  • efface.xlsm
    14.8 KB · Affichages: 36

Gardien de phare

XLDnaute Accro
Re : Simplifier un code

Bonjour,

VB:
' Effacement de Feuille de marque
Sub efface()
Dim Dd As Long
With Sheets("Feuille de marque")
For Dd = 2 To 1477 Step 25
.Range("D" & Dd).ClearContents
.Range("E" & Dd + 1).ClearContents
.Range("E" & Dd + 3).ClearContents
.Range("J" & Dd + 3).ClearContents
.Range("D" & Dd + 2 & ":F" & Dd + 2).UnMerge
.Range("D" & Dd + 2).ClearContents
.Range("I" & Dd + 2 & ":K" & Dd + 2).UnMerge
.Range("I" & Dd + 2).ClearContents
Next
End With
End Sub

Ps obligé de défusionner les cellules pour les effacer...
 

JCGL

XLDnaute Barbatruc
Re : Simplifier un code

Bonjour à tous,

Puis-je me permettre un petit rajout dans le code de remplissage :

.Range("D" & Dd) = Wt.Range("H" & i) 'Table
.Range("E" & Dd + 1) = Wt.Range("I3") 'N° de la Partie
.Range("E" & Dd + 3) = Wt.Range("F" & i) 'N°d'équipes
.Range("J" & Dd + 3) = Wt.Range("F" & i + 1)
.Range("D" & Dd + 2) = Wt.Range("G" & i) 'Nom
.Range("D" & Dd + 2 & ":F" & Dd + 2).Merge
.Range("I" & Dd + 2) = Wt.Range("G" & i + 1)
.Range("I" & Dd + 2 & ":K" & Dd + 2).Merge

A + à tous
 

Si...

XLDnaute Barbatruc
Re : Simplifier un code

salut

peut-être ainSi... (cellules fusionnées ou pas)
Code:
Sub efface()
  Dim R As Range
  With Sheets("Feuille de marque")
    For Each R In .Columns(4).SpecialCells(2)
      If R = "Partie:" Then R(0, 1) = "": R(1, 2) = "": R(2, 1) = "": R(2, 6) = "": R(3, 2) = "": R(3, 7) = ""
     Next
  End With
End Sub
 

Discussions similaires

Statistiques des forums

Discussions
311 729
Messages
2 081 971
Membres
101 852
dernier inscrit
dthi16088