XL 2016 VBA Copier Coller avec Condition

J

jl456

XLDnaute Junior
Bonjour,

Chaque jour, j'importe sous Excel une base de données qui comportent plusieurs onglets (dans mon exemple "Données1" ; "Données2").
Ces données concernent plusieurs utilisateurs (dans mon exemple : utilisateurs A ; B ; C).

Le nombre de lignes de données par utilisateur varie d'une journée à l'autre.

Je souhaite synthétisé dans une feuille les données pour 1 utilisateur.
Soit, pour l'utilisateur A :
"Voici les données 1 de la veille"
Copier coller de l'onglet "données1" avec la condition utilisateur "A"
Puis un saut de ligne
"Voici les données 2 de la veille"
Copier coller de l'onglet "données2" avec la condition utilisateur "A"
puis un saut de ligne

Pouvez-vous, s'il vous plait, me proposer un code VBA faisant cela ?

Merci d'avance.​
 

Pièces jointes

  • Insérer copier coller condition.xlsx
    10 KB · Affichages: 32
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Bonsoir jl456,

Curieux qu'il n'y ait pas de réponse, ce n'est pourtant pas bien compliqué.

La macro à placer dans ThisWorkbook :
Code: 
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Not Sh.Name Like "Utilisateur*" Then Exit Sub
Dim nom$, lig&, w As Worksheet, h&
Application.ScreenUpdating = False
Sh.Rows("2:" & Sh.Rows.Count).Delete 'RAZ
nom = Mid(Sh.Name, 13)
lig = 3
For Each w In Worksheets
    If w.Name Like "Données*" Then
        h = Application.CountIf(w.Columns(1), nom)
        If h Then
            Sh.Cells(lig, 1).End(xlUp)(3) = "Voici les " & LCase(w.Name) & " de la veille :"
            With w.[A1].CurrentRegion
                .AutoFilter 1, nom 'filtre automatique
                .Offset(1).Columns(2).Copy Sh.Cells(lig + 1, 1)
            End With
            w.AutoFilterMode = False 'retire le filtre automatique
            lig = lig + h + 2
        End If
    End If
Next
End Sub
Fichier joint.

A+
 

Pièces jointes

  • Insérer copier coller condition(1).xlsm
    27.1 KB · Affichages: 37
Vote positif 0 Vote négatif
J

jl456

XLDnaute Junior
Bonsoir Job75,

Je te remercie pour ton aide.
Si le nombre de colonnes varie d'une feuille de données à une autre et que je souhaite afin toute les colonnes dans la synthèse Utilisateur.
Peux-tu m'aider pour le code s'il te plait ?
De plus, j'aimerais garder les en-tête de colonne dans le copier / coller.

Merci d'avance.
 

Pièces jointes

  • Insérer copier coller condition(1).xlsm
    20.9 KB · Affichages: 30
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour jl456, le forum,

Il y a un oubli au post #2, il faut retirer .End(xlup)(3)

Pour la nouvelle demande voici la macro, toujours dans ThisWorkbook :
Code: 
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Not Sh.Name Like "Utilisateur*" Then Exit Sub
Dim nom$, lig&, w As Worksheet, h&, ncol%
Application.ScreenUpdating = False
Sh.Rows("2:" & Sh.Rows.Count).Delete 'RAZ
nom = Mid(Sh.Name, 13)
lig = 3
For Each w In Worksheets
    If w.Name Like "Données*" Then
        h = Application.CountIf(w.Columns(1), nom) + 1
        If h > 1 Then
            Sh.Cells(lig, 1) = "Voici les " & LCase(w.Name) & " de la veille :"
            With w.[A1].CurrentRegion
                ncol = .Columns.Count - 1
                .AutoFilter 1, nom 'filtre automatique
                If ncol Then .Columns(2).Resize(, ncol).Copy Sh.Cells(lig + 1, 1)
            End With
            w.AutoFilterMode = False 'retire le filtre automatique
            lig = lig + h + 2
        End If
    End If
Next
End Sub
Fichier (2).

A+
 

Pièces jointes

  • Insérer copier coller condition(2).xlsm
    26.8 KB · Affichages: 41
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re,

Une variante (3) avec une seule feuille pour étudier l'utilisateur :
Code: 
Private Sub Worksheet_Activate()
WorkSheet_Change [A1] 'lance la macro pour mise à jour
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1]) Is Nothing Then Exit Sub
Dim nom$, lig&, w As Worksheet, h&, ncol%
Application.ScreenUpdating = False
Rows("2:" & Rows.Count).Delete 'RAZ
nom = [A1]
If nom = "" Then Exit Sub
lig = 3
For Each w In Worksheets
    If w.Name Like "Données*" Then
        h = Application.CountIf(w.Columns(1), nom) + 1
        If h > 1 Then
            Cells(lig, 1) = "Voici les " & LCase(w.Name) & " de la veille :"
            With w.[A1].CurrentRegion
                ncol = .Columns.Count - 1
                .AutoFilter 1, nom 'filtre automatique
                If ncol Then .Columns(2).Resize(, ncol).Copy Cells(lig + 1, 1)
            End With
            w.AutoFilterMode = False 'retire le filtre automatique
            lig = lig + h + 2
        End If
    End If
Next
With UsedRange: End With 'actualise les barres de défilement
End Sub
A+
 

Pièces jointes

  • Insérer copier coller condition(3).xlsm
    27.2 KB · Affichages: 33
Vote positif 0 Vote négatif
J

jl456

XLDnaute Junior
Super !!!
Merci Job75 pour l'ajustement des largeurs de colonnes, je n'osais pas le demander. Cela améliore beaucoup mon fichier.
En fait, je vais garder 1 onglet par utilisateur afin de le mettre en partagé pour qu'ils puissent documenter des commentaires sur les valeurs en simultané.
Merci beaucoup.
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re,
jl456 à dit:
En fait, je vais garder 1 onglet par utilisateur
Cliquez pour agrandir...
Alors utilisez ce fichier (2 bis) et cette macro :
Code: 
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Not Sh.Name Like "Utilisateur*" Then Exit Sub
Dim nom$, lig&, w As Worksheet, h&, ncol%, r As Range, P As Range
Application.ScreenUpdating = False
Sh.Rows("2:" & Sh.Rows.Count).Clear 'RAZ
Sh.Columns.ColumnWidth = 10.71
nom = Mid(Sh.Name, 13)
lig = 3
For Each w In Worksheets
    If w.Name Like "Données*" Then
        h = Application.CountIf(w.Columns(1), nom) + 1
        If h > 1 Then
            Sh.Cells(lig, 1) = "Voici les " & LCase(w.Name) & " de la veille :"
            With w.[A1].CurrentRegion
                ncol = .Columns.Count - 1
                .AutoFilter 1, nom 'filtre automatique
                If ncol Then
                    Set r = Sh.Cells(lig + 1, 1).Resize(h)
                    .Columns(2).Resize(, ncol).Copy r
                    Set P = Union(IIf(P Is Nothing, r, P), r)
                End If
            End With
            w.AutoFilterMode = False 'retire le filtre automatique
            lig = lig + h + 2
        End If
    End If
Next w
'---largeur des colonnes---
Sh.Columns(2).Resize(, Sh.Columns.Count - 1).AutoFit
If Not P Is Nothing Then P.Columns.AutoFit
'---coloration en A1---
Sh.Rows(1).Interior.ColorIndex = xlNone
For ncol = 1 To Sh.Columns.Count
    With Sh.Cells(1).Resize(, ncol)
        If .Width > 100 Then .Interior.Color = RGB(146, 208, 80): Exit For 'largeur 100 à adapter
    End With
Next ncol
With Sh.UsedRange: End With 'actualise les barres de défilement
End Sub
Bonne nuit.
 

Pièces jointes

  • Insérer copier coller condition(2 bis).xlsm
    29.9 KB · Affichages: 32
Dernière édition:
Vote positif 0 Vote négatif
J

jl456

XLDnaute Junior
re Bonjour Job75,

Je suis désolé, mais j'ai encore un problème.
Tout fonctionne bien, si je ne suis pas en mode "partagé".
Dès que j'enclenche le mode partagé, lorsque je pointe un onglet "utilisateur", cela tourne en rond sans fin et sans actualisation.
Je suis obligé de tuer le processus Excel.
Y a t'il un moyen de pourvoir utiliser la macro en mode partagé ?
merci d'avance pour ton aide.
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour jl456, le forum,

Dans un classeur partagé on ne peut pas insérer ou supprimer des blocs de cellules.

Dans le fichier (2 bis) du post #9 je viens donc tout simplement de remplacer :
Code: 
Sh.Rows("2:" & Sh.Rows.Count).Delete 'RAZ
par :
Code: 
Sh.Rows("2:" & Sh.Rows.Count).Clear 'RAZ
Pour masquer le quadrillage il a suffit d'utiliser la commande dédiée du menu MISE EN PAGE.

Maintenant il n'y a plus de problème.

A+
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re,

Informations tirées de l'aide Microsoft concernant le partage des classeurs :

upload_2018-7-2_13-40-2.png


A+
 

Pièces jointes

  • upload_2018-7-2_13-37-13.png
    upload_2018-7-2_13-37-13.png
    11.4 KB · Affichages: 27
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re,

Vous parliez de faire inscrire des commentaires par les utilisateurs.

Mais cela ne peut pas se faire sur leurs feuilles puisque celles-ci sont effacées à leur activation.

Je reviens donc sur le fichier (4) : en l'état il ne peut pas être partagé puisqu'on fusionne la cellule A1 (cf post #14).

Pour le partager il faut utiliser une ComboBox avec ce fichier (4 bis) :
Code: 
Private Sub Worksheet_Activate()
ComboBox1_Change 'lance la macro pour mise à jour
End Sub

Private Sub ComboBox1_Change()
Dim nom$, lig&, w As Worksheet, h&, ncol%, r As Range, P As Range
Application.ScreenUpdating = False
Rows("2:" & Rows.Count).Clear 'RAZ
Columns.ColumnWidth = 10.71
If ComboBox1.ListIndex = -1 Then ComboBox1 = "": GoTo 1
nom = Mid(ComboBox1, 13)
lig = 3
For Each w In Worksheets
    If w.Name Like "Données*" Then
        h = Application.CountIf(w.Columns(1), nom) + 1
        If h > 1 Then
            Cells(lig, 1) = "Voici les " & LCase(w.Name) & " de la veille :"
            With w.[A1].CurrentRegion
                ncol = .Columns.Count - 1
                .AutoFilter 1, nom 'filtre automatique
                If ncol Then
                    Set r = Cells(lig + 1, 1).Resize(h)
                    .Columns(2).Resize(, ncol).Copy r
                    Set P = Union(IIf(P Is Nothing, r, P), r)
                End If
            End With
            w.AutoFilterMode = False 'retire le filtre automatique
            lig = lig + h + 2
        End If
    End If
Next w
'---largeur des colonnes---
Columns(2).Resize(, Columns.Count - 1).AutoFit
If Not P Is Nothing Then P.Columns.AutoFit
1 With UsedRange: End With 'actualise les barres de défilement
[A1].Select
End Sub

Private Sub ComboBox1_GotFocus()
ComboBox1 = ""
ComboBox1.List = Array("UTILISATEUR A", "UTILISATEUR B", "UTILISATEUR C") 'à adapter
ComboBox1.DropDown
End Sub
A+
 

Pièces jointes

  • Insérer copier coller condition(4 bis).xlsm
    34.6 KB · Affichages: 32
Vote positif 0 Vote négatif

Discussions similaires

A
  • Résolu(e)
XL 2016 Copier Coller données avec VBA dernière cellules vide
Réponses
13
Affichages
218
Anto35200
A
J
  • Question
XL 2021 Segments et tcd non liés
Réponses
4
Affichages
271
chris
chris
J
  • Question
Microsoft 365 extraction VBA avec formule si
Réponses
10
Affichages
327
Phil69970
Phil69970
E
  • Résolu(e)
Microsoft 365 copier coller Resize
2 3 4
Réponses
56
Affichages
1 K
Phil69970
Phil69970
P
  • Question
XL 2021 Code VBA pour copier coller des données de cellules d'une feuille a une autre
Réponses
4
Affichages
235
phoceenjo
P
S
  • Résolu(e)
Autres Copier-Coller en recherchant une ligne spécifique VBA
Réponses
4
Affichages
273
sambio2
S
Y
  • Question
Microsoft 365 Code VBA
Réponses
6
Affichages
387
yapad05
Y
G
  • Question
Microsoft 365 Macro VBA - Excel
Réponses
12
Affichages
227
Dranreb
Dranreb
R
  • Question
Microsoft 365 VBA copier coller des cellules
Réponses
6
Affichages
607
Phil69970
Phil69970
O
  • Question
Microsoft 365 Macro copier avec condition
Réponses
9
Affichages
391
Staple1600
Staple1600

Membres actuellement en ligne

Aucun membre en ligne actuellement.
0 membres et 49 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 069
Messages
2 085 040
Membres
102 763
dernier inscrit
NICO26