Aide et modif code vba(RESOLU)

chaelie2015

XLDnaute Accro
Bonsoir
je souhaite encore développer le code de PAF ( Merci) ( le lien :https://www.excel-downloads.com/threads/transfere-copier-renommer.227757/)
ci dessous le code complet
PHP:
Private Sub CommandButton6_Click()
 Dim DerLig As Integer, NumLig As Integer, WCible As Worksheet, TabTmp, FeuilleExistante
    
    Application.ScreenUpdating = False
    Sheets("Canevas").Visible = True
  
  With Worksheets("FNA")

  'vérifie que la feuille à créer n'existe pas
     FeuilleExistante = IsError(Evaluate("='" & .Range("T10") & "'!A1"))
     If Not FeuilleExistante Then
         MsgBox " impossible de poursuivre. La feuille " & .Range("T10") & " existe déjà"
         Exit Sub
     End If

  'Création nouvelle feuille
      
      Worksheets("Canevas").Copy After:=Worksheets(Worksheets.Count)
     
      ActiveSheet.Name = .Range("T10")
      Set WCible = ActiveSheet
      MsgBox " Une Copie de la Note " & .Range("T10") & " a été crée."
      WCible.Visible = xlVeryHidden
      
  ' Copie des données
      DerLig = .Range("B" & Rows.Count).End(xlUp).Row
      TabTmp = .Range("B25:B" & DerLig)
      WCible.Range("B14").Resize(UBound(TabTmp)) = TabTmp
      
  'copie des différentes cellules
      WCible.Range("D2") = .Range("E14") 
      WCible.Range("E4") = .Range("E15") 
      WCible.Range("E6") = .Range("E13") 
      WCible.Range("E8") = .Range("M17") 
      WCible.Range("K8") = .Range("Q22") '
      WCible.Range("B10") = .Range("T10") 
      WCible.Range("H10") = .Range("T9") 
      WCible.Range("E12") = .Range("T20") 
      '..... à compléter
      
  End With
  
   Sheets("Canevas").Visible = xlVeryHidden
    Application.ScreenUpdating = True
 
 CommandButton_valider_note.Visible = True
End Sub

la partie concernée est
PHP:
  ' Copie des données 
      DerLig = .Range("B" & Rows.Count).End(xlUp).Row
      TabTmp = .Range("B25:B" & DerLig)
      WCible.Range("B14").Resize(UBound(TabTmp)) = TabTmp
je souhaite ajouté d'autre plages et les limitées
la 1 plage est de B25:B40
la 2eme plage de B47:B56
et la 3 eme plage de B58:B67
Salutations
 
Dernière édition:

Paf

XLDnaute Barbatruc
Re : Aide et modif code vba

Bonjour,

si tu pouvais mettre le classeur en PJ, cela aiderait pour les tests.

je ne sais plus pourquoi j'avais utilisé un tableau pour copier les données plutôt que d'affecter les plages directement.

A+
 

Paf

XLDnaute Barbatruc
Re : Aide et modif code vba

Re

une solution qui copie l'ensemble de la plage B25:B67 sans grands changements du code

modifier la partie ' Copie des données

TabTmp = .Range("B25:B67")
WCible.Range("B14").Resize(UBound(TabTmp)) = TabTmp




autre solution

si les cellules de colonne B à colonne X sont fusionnées (comme dans l'exemple jusqu'en ligne 44)

plage par plage
Worksheets("A").Range("B25:X40").Copy Worksheets("polo").Range("B14:X29")
Worksheets("A").Range("B47:X56").Copy Worksheets("polo").Range("B36:X45")
Worksheets("A").Range("B58:X67").Copy Worksheets("polo").Range("B47:X56")


ou pour la plage complète
Worksheets("A").Range("B25:X67").Copy Worksheets("polo").Range("B14:X56")

si les cellules ne sont pas fusionnées
Worksheets("A").Range("B25:B40").Copy Worksheets("polo").Range("B14")
Worksheets("A").Range("B47:B56").Copy Worksheets("polo").Range("B36")
Worksheets("A").Range("B58:B67").Copy Worksheets("polo").Range("B47")


ou pour la plage complète
Worksheets("A").Range("B25:B67").Copy Worksheets("polo").Range("B14")

A+
 

chaelie2015

XLDnaute Accro
Re : Aide et modif code vba

Re

une solution qui copie l'ensemble de la plage B25:B67 sans grands changements du code

modifier la partie ' Copie des données

TabTmp = .Range("B25:B67")
WCible.Range("B14").Resize(UBound(TabTmp)) = TabTmp

Merci paf pour cette solution,
mais est ce que il y a la possibilité de copier que les cellules non vide de cette plage B25:B67
parce que je peux avoir des plages vide exemple de B30:B40 et de B45:B60
Salutations
 

Paf

XLDnaute Barbatruc
Re : Aide et modif code vba

Re

Post #1
je souhaite ajouté d'autre plages et les limitées
la 1 plage est de B25:B40
la 2eme plage de B47:B56
et la 3 eme plage de B58:B67

post #6
je peux avoir des plages vide exemple de B30:B40 et de B45:B60

Définissez exactement et une bonne fois votre besoin et le positionnement des données en colonne B!

Précisez également la présence ou non des cellules fusionnées ( qui ne servent à rien )sur l'ensemble ou non de la colonne B

A+
 

chaelie2015

XLDnaute Accro
Re : Aide et modif code vba

Bonjour
Merci PAF pour les commentaire, comme j'ai signalé dans le post#1 (d'ou le souci est résolut) j'ai souhaité cette fois copier que les cellules non vide de ces plages.
exemple dans la plage B25:B40 (désolé je vous confirme que la colonne B! est fusionnée B25:X25 etc)
La ligne B30:X30
jusqu'a la ligne B40:X40
sont vide
la palge de B47:B56 EXEMPLE les plage vide sont de B50 au B56
La plage B58:B67 ne sont pas vide
donc je souhaite copie seulement les page B25:B29 et B47:B49 et B58:B67
sALUTATIONS
 

Paf

XLDnaute Barbatruc
Re : Aide et modif code vba

Re

A la suite de ' Copie des données , remplacer les 3 lignes de code par

Code:
'plage1
LigFin = Worksheets("A").Range("B40").End(xlUp).Row
Inter = LigFin - 25
FinCopie = 14 + LigFin - 25
Worksheets("A").Range("B25:X" & LigFin).Copy Worksheets("polo").Range("B14:X" & FinCopie)

'plage2
LigFinA = Worksheets("A").Range("B56").End(xlUp).Row
LigFinB = Worksheets("polo").Range("B" & Rows.Count).End(xlUp).Row + 1
FinCopie = LigFinA - 47
Worksheets("A").Range("B47:X" & LigFinA).Copy Worksheets("polo").Range("B" & LigFinB & ":X" & LigFinB + FinCopie)

'plage3
LigFinA = Worksheets("A").Range("B68").End(xlUp).Row
LigFinB = Worksheets("polo").Range("B" & Rows.Count).End(xlUp).Row + 1
FinCopie = LigFinA - 58
Worksheets("A").Range("B58:X" & LigFinA).Copy Worksheets("polo").Range("B" & LigFinB & ":X" & LigFinB + FinCopie)

Remplacer les "A" et "polo" par les noms réels des feuilles de votre classeur réel.

Pas sûr que ça fonctionne si une plage est vide totalement.

Bonne suite
 

Paf

XLDnaute Barbatruc
Re : Aide et modif code vba

re

le code corrigé pour prendre en compte les plages totalement vides

Code:
'plage1
LigFin = Worksheets("A").Range("B40").End(xlUp).Row
If LigFin >= 25 Then
    FinCopie = 14 + LigFin - 25
    Worksheets("A").Range("B25:X" & LigFin).Copy Worksheets("polo").Range("B14:X" & FinCopie)
End If
'plage2
LigFinA = Worksheets("A").Range("B56").End(xlUp).Row
If LigFinA >= 47 Then
    LigFinB = Worksheets("polo").Range("B" & Rows.Count).End(xlUp).Row + 1
    FinCopie = LigFinA - 47
    Worksheets("A").Range("B47:X" & LigFinA).Copy Worksheets("polo").Range("B" & LigFinB & ":X" & LigFinB + FinCopie)
End If
'plage3
LigFinA = Worksheets("A").Range("B68").End(xlUp).Row
If LigFinA >= 58 Then
    LigFinB = Worksheets("polo").Range("B" & Rows.Count).End(xlUp).Row + 1
    FinCopie = LigFinA - 58
    Worksheets("A").Range("B58:X" & LigFinA).Copy Worksheets("polo").Range("B" & LigFinB & ":X" & LigFinB + FinCopie)
End If

A+
 

chaelie2015

XLDnaute Accro
Re : Aide et modif code vba

Re
mais le pblm persiste tjr il est entrain de copie les données CHAQUE FOIS DANS la feuille POLO??

PHP:
Private Sub CommandButton6_Click()
 Dim DerLig As Integer, NumLig As Integer, WCible As Worksheet, TabTmp, FeuilleExistante
    
    Application.ScreenUpdating = False
    Sheets("Canevas").Visible = True
  
  With Worksheets("FNA")

  'vérifie que la feuille à créer n'existe pas
     FeuilleExistante = IsError(Evaluate("='" & .Range("T10") & "'!A1"))
     If Not FeuilleExistante Then
         MsgBox " impossible de poursuivre. La feuille " & .Range("T10") & " existe déjà"
         Exit Sub
     End If

  'Création nouvelle feuille
      
      Worksheets("Canevas").Copy After:=Worksheets(Worksheets.Count)
     
      ActiveSheet.Name = .Range("T10")
      Set WCible = ActiveSheet
      MsgBox " Une Copie de la Note " & .Range("T10") & " a été crée."
      WCible.Visible = xlVeryHidden
      
  ' Copie des données (Réserves)
    ' DerLig = .Range("B" & Rows.Count).End(xlUp).Row
    ' TabTmp = .Range("B25:B" & DerLig)
    ' WCible.Range("B14").Resize(UBound(TabTmp)) = TabTmp
      
  'plage1
LigFin = Worksheets("FNA").Range("B40").End(xlUp).Row
If LigFin >= 25 Then
    FinCopie = 14 + LigFin - 25
    Worksheets("FNA").Range("B25:X" & LigFin).Copy Worksheets("Canevas").Range("B14:X" & FinCopie)
End If
'plage2
LigFinA = Worksheets("FNA").Range("B56").End(xlUp).Row
If LigFinA >= 47 Then
    LigFinB = Worksheets("Canevas").Range("B" & Rows.Count).End(xlUp).Row + 1
    FinCopie = LigFinA - 47
    Worksheets("FNA").Range("B47:X" & LigFinA).Copy Worksheets("Canevas").Range("B" & LigFinB & ":X" & LigFinB + FinCopie)
End If
'plage3
LigFinA = Worksheets("FNA").Range("B68").End(xlUp).Row
If LigFinA >= 58 Then
    LigFinB = Worksheets("Canevas").Range("B" & Rows.Count).End(xlUp).Row + 1
    FinCopie = LigFinA - 58
    Worksheets("FNA").Range("B58:X" & LigFinA).Copy Worksheets("Canevas").Range("B" & LigFinB & ":X" & LigFinB + FinCopie)
End If
  'copie des différentes cellules
      WCible.Range("D2") = .Range("E14") '
      WCible.Range("E4") = .Range("E15") '
      WCible.Range("E6") = .Range("E13") '
      WCible.Range("E8") = .Range("M17") '
      WCible.Range("K8") = .Range("Q22") '
      WCible.Range("B10") = .Range("T10") '
      WCible.Range("H10") = .Range("T9") '
      WCible.Range("E12") = .Range("T20") '
      '..... à compléter
      
  End With
  
   Sheets("Canevas").Visible = xlVeryHidden
    Application.ScreenUpdating = True
 
 
End Sub
salutations
EDIT: j'ai remplacé A par FNA et polo par Canevas
c a d copie les données de FNA sous model canevas
 

Paf

XLDnaute Barbatruc
Re : Aide et modif code vba

re,

(a priori) il ne faut pas copier dans la feuille "canevas", puisque c'est le 'modèle'. plutôt comme ça pour profiter des déclarations déjà faites en début de code

Code:
  'plage1
LigFin = .Range("B40").End(xlUp).Row
If LigFin >= 25 Then
    FinCopie = 14 + LigFin - 25
    .Range("B25:X" & LigFin).Copy WCible.Range("B14:X" & FinCopie)
End If
'plage2
LigFinA = .Range("B56").End(xlUp).Row
If LigFinA >= 47 Then
    LigFinB = .Range("B" & Rows.Count).End(xlUp).Row + 1
    FinCopie = LigFinA - 47
    .Range("B47:X" & LigFinA).Copy WCible.Range("B" & LigFinB & ":X" & LigFinB + FinCopie)
End If
'plage3
LigFinA = .Range("B68").End(xlUp).Row
If LigFinA >= 58 Then
    LigFinB = .Range("B" & Rows.Count).End(xlUp).Row + 1
    FinCopie = LigFinA - 58
    .Range("B58:X" & LigFinA).Copy WCible.Range("B" & LigFinB & ":X" & LigFinB + FinCopie)
End If

Bonne suite
 

Discussions similaires

Réponses
8
Affichages
615

Statistiques des forums

Discussions
311 709
Messages
2 081 779
Membres
101 816
dernier inscrit
Jfrcs