XL 2019 copier coller vba

frederio

XLDnaute Impliqué
Bonjour a tous,

Sur la 1ère feuille " JUPILER PRO LEAGUE" Copie =G4:H375
Sur la 2ère feuille " %" Coller =I5:J409

MERCI
 

Pièces jointes

  • COPIE COLLER.xlsm
    854.6 KB · Affichages: 8

job75

XLDnaute Barbatruc
Bonjour frederio,

Formule matricielle en I5 :
Code:
=INDEX('JUPILER PRO LEAGUE'!G:G;EQUIV($H5&$K5;'JUPILER PRO LEAGUE'!$F$1:$F$375&'JUPILER PRO LEAGUE'!$I$1:$I$375;0))
à valider par Ctrl+Maj+Entrée et à copier sur J5 puis vers le bas.

A+
 

Pièces jointes

  • COPIE COLLER.xlsm
    854 KB · Affichages: 3

frederio

XLDnaute Impliqué
COMMENT FAIRE Sur la 2ère feuille " %" Coller =I5:J409



VB:
Sub sbCopyRangeToAnotherSheet()
'Set range
Sheets("JUPILER PRO LEAGUE").Range("G4:H12").Copy Destination:=Sheets("%").Range("I5")
'Copy the data
Sheets("JUPILER PRO LEAGUE").Range("G4:H12").Copy
'Activate the destination worksheet
Sheets("%").Activate
'Select the target range
Range("I5").Select
'Paste in the target destination
ActiveSheet.Paste

Application.CutCopyMode = False
End Sub
 

Pièces jointes

  • COPIE COLLER (2).xlsm
    853.9 KB · Affichages: 1

job75

XLDnaute Barbatruc
Il est beaucoup plus simple d'utiliser les formules suivantes :

- en H5, à copier-coller sur I5:K5 et vers le bas :
Code:
=INDEX('JUPILER PRO LEAGUE'!F:F;LIGNE()-1-ENT((LIGNE()-5)/12))
- en G17, à copier-coller vers le bas :
Code:
=INDEX('JUPILER PRO LEAGUE'!D:D;LIGNE()-1-ENT((LIGNE()-5)/12))
- en L17, à copier-coller vers le bas :
Code:
=INDEX('JUPILER PRO LEAGUE'!K:K;LIGNE()-1-ENT((LIGNE()-5)/12))
Ensuite il suffit de copier le tableau G17:L25 et de le coller sur les tableaux en dessous.

Bonne nuit.
 

Pièces jointes

  • COPIE COLLER(1).xlsm
    848.3 KB · Affichages: 4

job75

XLDnaute Barbatruc
Bonjour frederio, le forum,

La solution par formules précédente est la plus simple et donc la meilleure.

Mais si vous tenez absolument au VBA mettez cette macro dans le code de la feuille "%" :
VB:
Private Sub Worksheet_Activate()
Dim deb As Range, pas%, tablo, ncol%, resu, i&, ii&, jj%, j%, n&
Set deb = [G4] '1ère cellule de restitution, à adapter
pas = 11 'nombre de lignes de chaque journée
With Sheets("JUPILER PRO LEAGUE")
    tablo = .Range("D3", .Range("K" & .Rows.Count).End(xlUp))
    ncol = UBound(tablo, 2)
    ReDim resu(1 To UBound(tablo) + Application.CountIf(.[F:F], "JOURNEE*"), 1 To ncol - 2)
End With
'---remplissage du tableau et mises en forme---
Application.ScreenUpdating = False
deb.Resize(pas - 1, ncol - 2).ClearContents 'efface le contenu de la 1ère journée
For i = 1 To UBound(tablo)
    ii = ii + 1
    If i Mod pas = 1 Then '1ère ligne de chaque journée
        If i > 1 Then
            deb.EntireRow.Copy deb(ii).EntireRow 'copie la 1ère ligne
            deb(2).Resize(pas - 2, ncol - 2).Copy deb(ii + 1) 'copie la 1ère journée pour les formats
        End If
        deb(ii, 12).Resize(pas - 1).BorderAround Weight:=xlMedium 'contour colonne R
        n = n + 1
        resu(ii, 1) = "JOURNEE"
        resu(ii, ncol - 2) = n
    Else
        jj = 0
        For j = 1 To ncol
            jj = jj + 1
            resu(ii, jj) = tablo(i, j)
            If j = 1 Then j = 2 'saut de colonne
            If j = ncol - 2 Then j = ncol - 1 'saut de colonne
        Next j
    End If
    If i Mod pas = pas - 1 Then i = i + 1: ii = ii + 2 'sauts de lignes
Next i
ii = ii - 2 'évite les derniers sauts de lignes
'---restitution---
deb.Resize(ii, ncol - 2) = resu
deb.Offset(ii).EntireRow.Resize(Rows.Count - ii - deb.Row + 1).Delete 'RAZ en dessous
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Elle s'exécute quand on active la feuille, testez ce fichier (2).

Ce n'est quand même pas très simple.

A+
 

Pièces jointes

  • COPIE COLLER(2).xlsm
    642.3 KB · Affichages: 8

frederio

XLDnaute Impliqué
bonjour job

Activez la feuille "%"
Copie
Sur la 1ère feuille " JUPILER PRO LEAGUE" Copie =G4:H375
Coller
Sur la 2ère feuille " %" Coller =I5:J409


NE PAS TOUCHER

Sur la 1ère feuille " JUPILER PRO LEAGUE" Copie =D3:K375

Sur la 2ère feuille " %" Coller =G4:L409

PEUX TOUCHER
Sur la 1ère feuille " JUPILER PRO LEAGUE" Copie =G4:H375 ET Sur la 2ère feuille " %" Coller =I5:J409
 

frederio

XLDnaute Impliqué

comment faire plus rapide code vba​


VB:
Sub sbCopyRangeToAnotherSheet()
'Set range
Sheets("JUPILER PRO LEAGUE").Range("G4:H12").Copy Destination:=Sheets("%").Range("I5")
'Copy the data
Sheets("JUPILER PRO LEAGUE").Range("G4:H12").Copy
'Activate the destination worksheet
Sheets("%").Activate
'Select the target range
Range("I5").Select
'Paste in the target destination
ActiveSheet.Paste

Sheets("JUPILER PRO LEAGUE").Range("G15:H23").Copy Destination:=Sheets("%").Range("I17")
'Copy the data
Sheets("JUPILER PRO LEAGUE").Range("G15:H23").Copy
'Activate the destination worksheet
Sheets("%").Activate
'Select the target range
Range("I17").Select
'Paste in the target destination

Sheets("JUPILER PRO LEAGUE").Range("G26:H34").Copy Destination:=Sheets("%").Range("I29")
'Copy the data
Sheets("JUPILER PRO LEAGUE").Range("G26:H34").Copy
'Activate the destination worksheet
Sheets("%").Activate
'Select the target range
Range("I29").Select
'Paste in the target destination
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub
 

job75

XLDnaute Barbatruc
Bonjour frederio, le forum,
comment faire plus rapide code vba
La macro du post #5 s'exécute chez moi en 0,80 seconde et c'est vrai qu'on peut aller plus vite.

Dans ce fichier (3) la mise en forme des tableaux se fait d'un seul coup avant restitution des valeurs :
VB:
Private Sub Worksheet_Activate()
Dim deb As Range, pas%, tablo, ncol%, resu, i&, ii&, n&, jj%, j%
Set deb = [G4] '1ère cellule de restitution, à adapter
pas = 11 'nombre de lignes de chaque journée
With Sheets("JUPILER PRO LEAGUE")
    tablo = .Range("D3", .Range("K" & .Rows.Count).End(xlUp))
    ncol = UBound(tablo, 2)
    ReDim resu(1 To UBound(tablo) + Application.CountIf(.[F:F], "JOURNEE*"), 1 To ncol - 2)
End With
'---remplissage du tableau---
For i = 1 To UBound(tablo)
    ii = ii + 1
    If i Mod pas = 1 Then '1ère ligne de chaque journée
        n = n + 1
        resu(ii, 1) = "JOURNEE"
        resu(ii, ncol - 2) = n
    Else
        jj = 0
        For j = 1 To ncol
            jj = jj + 1
            resu(ii, jj) = tablo(i, j)
            If j = 1 Then j = 2 'saut de colonne
            If j = ncol - 2 Then j = ncol - 1 'saut de colonne
        Next j
    End If
    If i Mod pas = pas - 1 Then i = i + 1: ii = ii + 2 'sauts de lignes
Next i
ii = ii - 2 'évite les derniers sauts de lignes
'---mise en forme et restitution---
Application.ScreenUpdating = False
deb.Resize(pas - 1, ncol - 2) = "" 'efface le contenu de la 1ère journée
deb.EntireRow.Resize(pas + 1).Copy deb(pas + 2).EntireRow.Resize((n - 1) * (pas + 1)) 'copier-coller pour la mise en formex
deb.Resize(ii, ncol - 2) = resu
deb.Offset(ii).EntireRow.Resize(Rows.Count - ii - deb.Row + 1).Delete 'RAZ en dessous
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub
La macro s'exécute chez moi en 0,11 seconde.

A+
 

Pièces jointes

  • COPIE COLLER(3).xlsm
    641.2 KB · Affichages: 2
Dernière édition:

frederio

XLDnaute Impliqué
c est petite problème jaune
2022-04-16_14-08-39.png
 

job75

XLDnaute Barbatruc
Il n'y a pas de problème chez moi mais bon remplacez :
VB:
deb.Resize(pas - 1, ncol - 2).ClearContents 'efface le contenu de la 1ère journée
par :
Code:
deb.Resize(pas - 1, ncol - 2) = "" 'efface le contenu de la 1ère journée
Je corrige le post #10, prenez le dernier fichier.
 

Statistiques des forums

Discussions
312 836
Messages
2 092 656
Membres
105 479
dernier inscrit
chaussadas.renaud