XL 2010 Copie de données vers différents onglets à créer

citizenbaban

XLDnaute Junior
Bonjour le forum,

J'ai un petit problème avec un code VBA et je n'ai pas trouvé mon bonheur sur le forum :(

Voici le topo : un onglet base de données (BdD dans le fichier joint) pour lequel j'aimerai que chaque ligne qui contiennent 2017 dans la colonne A soit copiée dans l'onglet "2017", idem pour 2018, etc.
Cette partie là fonctionne, quoi que mon code peut sûrement être optimisé / épuré car j'ai en fait une macro par "année".
L'idée c'est que l'on arrive en 2019 bientôt, puis 2020, etc. Les onglets "2019", "2020", seront créés par macro à partir d'une trame (celle là marche aussi) mais j'aimerai ne pas avoir à réadapter la macro "copie de données" à chaque nouvelle année.
J'aimerai que le code réponde à ceci : si valeur en Ax de l'onglet BdD, alors copier la ligne dans l'onglet dont le nom est égal à cette valeur Ax. Et ce pour toutes les lignes :)
Je pense cerner un peu l'idée mais je sèche sur sa transposition en VBA :(

Bonne fêtes à tous.

Citizen
 

Pièces jointes

  • Citizen.xls
    79 KB · Affichages: 21

citizenbaban

XLDnaute Junior
J'ai mouliné ce bout de code mais il tourne dans le vide

Code:
Sub Copier_Lignes_Global()

Application.ScreenUpdating = True

Dim C, I, Compteur As Integer
Dim sBdD As Worksheet
Set sBdD = Worksheets("BdD")
Dim derLig As Long
derLig = sBdD.Cells(Rows.Count, 1).End(xlUp).Row
  
    For Compteur = 2 To ThisWorkbook.Sheets.Count
       
        sBdD.Activate
        C = 4
        For I = 3 To derLig
            If sBdD.Cells(I, 1).Text = ActiveSheet.Name Then
            sBdD.Range(Cells(I, 2), Cells(I, 20)).Copy
            ActiveSheet.Cells(C, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
   
            C = C + 1
            End If
        Next I
     
        Compteur = Compteur + 1
    Next


Application.CutCopyMode = False
Application.ScreenUpdating = True


End Sub
 

citizenbaban

XLDnaute Junior
Il y a du mieux...ce code-ci marche pour un de mes 3 onglets (mais pas pour les autres et je ne sais pas pourquoi...)

Code:
Sub Copier_Lignes_Global()

Application.ScreenUpdating = True

Dim C, I, Compteur, Total_onglet As Integer
Total_onglet = ThisWorkbook.Sheets.Count
Dim sBdD As Worksheet
Set sBdD = Worksheets("BdD")
Dim derLig As Long
derLig = sBdD.Cells(Rows.Count, 1).End(xlUp).Row
  
    For Compteur = 2 To Total_onglet
       
        sBdD.Activate
        C = 4
        For I = 3 To derLig
            If sBdD.Cells(I, 1).Text = ThisWorkbook.Sheets(Compteur).Name Then
            sBdD.Range(Cells(I, 2), Cells(I, 20)).Copy
            ThisWorkbook.Sheets(Compteur).Cells(C, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
   
            C = C + 1
            End If
        Next I
     
        Compteur = Compteur + 1
    Next


Application.CutCopyMode = False
Application.ScreenUpdating = True


End Sub
 

citizenbaban

XLDnaute Junior
Bon il y a vraiment quelque chose qui m'échappe, si quelqu'un veut bien me dire pourquoi ma macro ne se déroule pas sur les onglets 3, 4 et 5 je suis preneur.
J'abandonne pour aujourd'hui.

Merci

Citizen


Edit : en fait pour être précis, la macro ne se déroule qu'un onglet sur 2, qu'il soit "pair" ou "impair" dans son nom objet (feuil1, feuil2, etc)

Edit2 : Ok je suis un boulet, je viens de voir mon erreur.....un next qui trainait en fin de code, résidu d'un mauvais copier/coller...
 

Pièces jointes

  • Citizen.xls
    94.5 KB · Affichages: 22
Dernière édition:

citizenbaban

XLDnaute Junior
Bonne année à tous,

Est-ce que quelqu'un a pu regarder mon code afin de savoir si il pouvait être épuré?

Code:
Sub Copier_Ligne_Global_Plus_Nettoyage()

Application.ScreenUpdating = False

Dim C, I, Compteur, N, V, Total_onglet As Integer
Total_onglet = ThisWorkbook.Sheets.Count
Dim sArch As Worksheet
Set sArch = Worksheets("Archives")
Dim derLig As Long
derLig = sArch.Cells(Rows.Count, 1).End(xlUp).Row
Dim lastLig As Long
Dim CelVide As Range



        For V = 4 To Total_onglet
        Sheets(V).Activate
        lastLig = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        If lastLig > 3 Then
        Range(Cells(4, 1), Cells(lastLig, 19)).Select
        Selection.EntireRow.Delete
        Else
        End If
        Next V



        sArch.Activate
        Cells.EntireColumn.Hidden = False



        For Compteur = 4 To Total_onglet
       
        sArch.Activate
        C = 4
        For I = 3 To derLig
        If sArch.Cells(I, 1).Text = ThisWorkbook.Sheets(Compteur).Name Then
        sArch.Range(Cells(I, 2), Cells(I, 20)).Copy
        ThisWorkbook.Sheets(Compteur).Cells(C, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

        C = C + 1
        End If
        Next I
     
        Next Compteur




        For N = 4 To Total_onglet
        Sheets(N).Activate
        lastLig = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row


        Range(Cells(4, 1), Cells(lastLig, 19)).Select
        Selection.Borders.Value = 1


        For Each CelVide In Range(Cells(4, 1), Cells(lastLig, 19))
        If CelVide = "" Then CelVide.Interior.Color = RGB(206, 206, 206)
        Next CelVide
       
        Cells(lastLig + 1, 1).Activate
        Cells(lastLig + 1, 1).Show
        Next N


        sArch.Activate
        Range("A:A").EntireColumn.Hidden = True
        Cells(lastLig, 2).Activate
        Cells(lastLig, 2).Show
       
       
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

J'ai également une petite question car il me fait quelque chose d'un peu étrange, bien que purement esthétique : La fin du code sert pour la mise en forme des lignes, notamment pour griser les cellules vides. Comme j'ai mis un range plutôt qu'une boucle, si la macro tourne sans valeur à copier, elle va me griser la ligne 4. Ca en soit, ce n'est pas grave. Mais si je la relance avec cette fois une valeur à copier, elle va me copier cette valeur ligne 4, très bien, mais la ligne va rester grise, alors que le début de code est sensé supprimer les lignes à partir de la ligne 4. Pourquoi est-ce que je ne me retrouve pas avec une ligne blanche avant la copie des données et que j'ai une ligne grise ?

Merci

Citizen
 

cp4

XLDnaute Barbatruc
Bonjour,

Si j'ai bien compris, macro à tester
VB:
Option Explicit

Sub Dispatcher()
  Dim ShBd As Worksheet, ShTr As Worksheet, d As Object, i As Integer, Sh As Worksheet, dl As Integer, clé, c As Range
  Set ShBd = ThisWorkbook.Worksheets("BdD")
  Set ShTr = ThisWorkbook.Worksheets("Trame")
  Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
  For Each Sh In Worksheets
  If Sh.Name <> ShBd.Name And Sh.Name <> ShTr.Name Then
  Application.DisplayAlerts = False
  Sh.Delete
  Application.DisplayAlerts = True
  End If
  Next

  With ShBd
  dl = .Range("A" & Rows.Count).End(xlUp).Row
  For i = 3 To dl
  If Not d.exists(.Range("A" & i).Value) Then
  d(.Range("A" & i).Value) = ""
  End If
  Next i
  End With

  ShTr.Visible = xlSheetVisible

  For Each clé In d.keys
  Sheets.Add(after:=Sheets(Sheets.Count)).Name = clé
  ShTr.Range("A1").CurrentRegion.Copy ActiveSheet.Range("A1")
  ActiveSheet.Range("A1") = clé
  For Each c In ShBd.Range("A3:A" & ShBd.Range("A" & Rows.Count).End(xlUp).Row)
  If c.Value = clé Then
  i = c.Row
  dl = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
  ShBd.Range(ShBd.Cells(i, 2), ShBd.Cells(i, 20)).Copy Destination:=ActiveSheet.Cells(dl, 1)
  End If
  Next
  Next
  ShTr.Visible = xlSheetHidden
  ShBd.Activate
  Application.ScreenUpdating = True
End Sub
 

citizenbaban

XLDnaute Junior
Bonjour Cp4,

J'ai une erreur d'exécution 1004 sur la ligne 29 : Sheets.Add(after:=Sheets(Sheets.Count)).Name = clé

Est-ce que tu peux m'expliquer un peu ton code pour être sûr que je ne sois pas à côté de la plaque ? surtout pour ces points :
Code:
Set d = CreateObject("Scripting.Dictionary")
Code:
For Each clé In d.keys

Je te remercie,

Bonne journée.

Citizen
 

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 925
Membres
101 841
dernier inscrit
ferid87