VBA exploser un tableau en plusieurs feuilles en fct d'une valeur

VBA exploser un tableau en plusieurs feuilles en fct d'une valeur - Logiciels - Windows & Software

Marsh Posté le 13-04-2018 à 07:35:29    

Bonjour à tous,
 
Nouveau sur ce forum je suis à la recherche de quelqu'un pour m'aider sur le développement de mon code vba.
 
J'ai une feuille principale appelée "sheet1" sur laquelle je travaille quotidiennement.
La colonne A contient des valeurs telles que "JAN 2018", "FEB 2018", "MAR 2018", etc.
J'aimerais que mon code me permette de copier chaque ligne qui contient JAN 2018 en colonne A de la feuille sheet1 dans une feuille appelée "JAN 2018", FEB 2018 dans une feuille appelée "FEB 2018", etc.
L'idée est de faire une copie et non d'effacer les données de ma feuille principale de sorte que je puisse continuer à récolter quotidiennement mes données.
 
Grand débutant en vba j'ai trouvé un bout de code sur internet que j'essaie de modifier pour obtenir ce que je veux mais j'ai du mal. Je vous mets le code que j'ai actuellement.
Pour le développement je travaille avec des simplifications :
- JAN 2018 = aaa ; FEB 2018 = bbb, etc.
 
Pour être sûr de ne pas effacer mes données je commence par copier ma feuille.
Ensuite je définis les mots clés, je fais la recherche, je copie et je supprime pour éviter que mon code tourne en boucle. Pour finir je renomme mes feuilles avec mes mots clés. Le problème ici est que si j'ai créé puis supprimé plusieurs feuilles, mon renommage ne marchera pas car je serai peut-être en train de travailler avec des sheet22, sheet30 ou autre.
 
Il y a plusieurs choses que je n'arrive pas à faire :
- Si je n'ai pas suffisamment de feuilles créées le code ne marche pas.
- Je ne sais pas comment faire pour que les feuilles dans lesquelles se mettent les données s'appellent aaa, bbb, ccc, etc.
 
Quelques idées que j'ai pour dévier mon problème mais que je ne sais pas comment coder :
- Commencer par créer différentes feuilles appelées aaa, bbb, ccc, etc.
- Lancer ma recherche de mot clé et en fonction du résultat copier directement la ligne dans la feuille correspondante.
 
Comment pouvez-vous m'aider à résoudre mon problème ? J'espère avoir été suffisamment clair sinon n'hésitez surtout pas à me poser des questions.
 
Merci par avance.
 
Arnaud
 

Code :
  1. Sub CutData()
  2. Dim MotCle
  3. Dim a As Byte
  4. Dim i As Byte
  5. Dim C As Range
  6. Dim F As String
  7. Dim Ligne As Long
  8.     'On copie la feuille
  9.     a = Sheets.Count
  10.     Sheets("sheet1" ).Select
  11.     Sheets("sheet1" ).Copy After:=Sheets(a)
  13.     'On définit les mots clés
  14.     MotCle = Array("aaa", "bbb", "ccc", "ddd" )
  15.     'On effectue la recherche de chaque mot clé dans la colonne A de la sheet1
  16.     For i = 0 To UBound(MotCle)
  17.         Do
  18.             Set C = Worksheets("sheet1 (2)" ).Columns(1).Find(MotCle(i), LookIn:=xlValues, lookat:=xlPart)
  19.             If Not C Is Nothing Then
  20.             F = "sheet" & (i + 2)
  21.             With Worksheets(F)
  22.             'On définit la ligne où sera effectué le collage
  23.             Ligne = .Range("F" & Rows.Count).End(xlUp).Row + 1
  24.             'On effectue le copier / coller
  25.             C.EntireRow.Copy .Range("A" & Ligne)
  26.             'On supprime la ligne dans la sheet1(2)
  27.             C.EntireRow.Delete
  28.             End With
  29.             End If
  30.         Loop While Not C Is Nothing
  31.     Next i
  33.     'On renomme les feuilles
  34.     Worksheets("sheet2" ).Name = "aaa"
  35.     Worksheets("sheet3" ).Name = "bbb"
  36.     Worksheets("sheet4" ).Name = "ccc"
  37.     Worksheets("sheet5" ).Name = "ddd"
  39. End Sub

Reply

Marsh Posté le 13-04-2018 à 07:35:29   

Reply

Marsh Posté le 16-04-2018 à 11:51:55    

Euh, je suis pas sûr de comprendre le but, mais à vue de nez un tableau croisé ferait la même chose. En beaucoup plus simple à maintenir et  utiliser.

Reply

Marsh Posté le 17-04-2018 à 07:18:22    

Bonjour,
 
Je suis conscient que la même chose pourrait être faite en tableau croisé mais les personnes qui vont utiliser les données ne savent pas utiliser ce genre d'outil. C'est pourquoi je me suis tourné vers une solution "automatique".
 
Si jamais ça intéresse des personnes voilà le code que j'ai obtenu aujourd'hui ainsi que les deux points sur lesquels je bute actuellement.
• Le code crée différentes feuilles en fonction des dates qui sont présentes en colonne A de la feuille sheet1 mais je souhaiterais copier sur chaque nouvelle feuille créée un entête présent sur la feuille sheet1. En me basant sur le nom de la feuille en question j'arrive à copier l'entête mais si demain je rajoute une date et donc une feuille nouvelle mon programme ne sera pas complet et certaines feuilles n'auront pas d'entête.
• Le code copie les données en fonction du mot clé (mois) dans des feuilles nouvelles mais je voudrais les copier dans les feuilles déjà créés auparavant. Par exemple si le mot clé trouvé est JAN 18 je voudrais que le code ouvre la feuille JAN 2018 déjà existante et copie la ligne entière à cet endroit là.
 
Bonne journée à tous.
 

Code :
  1. Sub CutData()
  3. Dim MotCle
  4. Dim a As Byte
  5. Dim i As Byte
  6. Dim c As Range
  7. Dim F As String
  8. Dim Ligne As Long
  9. Dim Nom As String
  10. Dim d As Range
  11. Dim n As Byte
  12. Const lideb = 1
  13. Const lifin = 30
  14. Dim plage As Range
  15. Dim li As Long
  17.     'On supprime toutes données dans la feuille MonthsExtract
  18.         Worksheets("MonthsExtract" ).Range("A1:A65536" ).ClearContents
  20.     'On supprime la sheet1 (2) qui est la copie des données d'origines
  21.         On Error Resume Next
  22.             Application.DisplayAlerts = False
  23.             Sheets("sheet1 (2)" ).Delete
  24.             Application.DisplayAlerts = True
  27.    'On copie la feuille de données
  28.             a = Sheets.Count
  29.             Sheets("sheet1" ).Select
  30.             Sheets("sheet1" ).Copy After:=Sheets(a)
  33.     'On copie les mois existants en supprimant les doublons dans un onglet MonthsExtract
  34.             Range("A11:A" & Range("A65536" ).End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Worksheets("MonthsExtract" ).Range("A1" ), Unique:=True
  35.             With ThisWorkbook.Worksheets("MonthsExtract" ).Range("A1" )
  36.                 If .Value = "(%)" Then .EntireRow.Delete
  37.             End With
  40.     'On crée nouvelle feuille pour chaque mois existant
  41.             With ActiveSheet.Name = Sheets("MonthsExtract" )
  42.                 For li = 1 To Range("A" & Rows.Count).End(xlUp).Row 'JE VOUDRAIS QUE LA BOUCLE S'ARRETE QUAND LE CODE RENCONTRE UNE CELLULE EN A VIDE
  43.                 Sheets.Add
  44.                 ActiveSheet.Name = Sheets("MonthsExtract" ).Range("A" & li)
  45.                 plage.Copy .Range("A" & li)
  46.                 Next li
  47.             End With
  48.             Application.DisplayAlerts = False 'deactive les messages autorisation d'effacer
  50.             For Each Sh In Sheets
  51.     'On supprime les feuilles qui commencent par Feuil
  52.             If Left(Sh.Name, 5) = "Feuil" Then Sh.Delete
  53.             Next
  54.             Application.DisplayAlerts = True 'reactive les messages autorisation d'effacer
  56.     'On copie les entetes
  57.   '         For Each Sh In Worksheets
  58.                 Sheets("sheet1" ).Range("A7:Z11" ).Copy
  59.                 Sheets("APR 2018" ).Range("A1" ).PasteSpecial Paste:=xlPasteFormulas 'JE VOUDRAIS COPIER SUR CHAQUE FEUILLE CREEE PEU IMPORTE SON NOM (EN GROS CHAQUE FEUILLE QUI CORRESPOND A UN MOIS), JE NE SAIS PAS SI ON PEUT UTILISER LA LISTE MONTHSEXTRACT ?
  60.                 Sheets("APR 2018" ).Range("A1" ).PasteSpecial Paste:=xlPasteFormats
  64.     'On définit les mots clés
  65.                 MotCle = Array("MAY 17", "JUN 17", "JUL 17", "AUG 17", "SEP 17", "OCT 17", "NOV 17", "DEC 17", "JAN 18", "FEB 18", "MAR 18", "APR 18", "MAY 18", "JUN 18", "JUL 18", "AUG 18", "SEP 18", "OCT 18", "NOV 18", "DEC 18" )
  66.     'On effectue la recherche de chaque mot clé dans la colonne A de la sheet1
  67.                 For i = 0 To UBound(MotCle)
  68.                     Do
  69.                         Set c = Worksheets("sheet1 (2)" ).Columns(1).Find(MotCle(i), LookIn:=xlValues, lookat:=xlPart)
  70.     'Si le mot clé est trouvé
  71.                         If Not c Is Nothing Then
  72.     'On définit le nom de la feuille où sera effectuée la copie
  73.                         F = "sheet" & (i + 2) 'JE VOUDRAIS COPIER LES DONNEES DANS LES ONGLETS PRECEDEMMENT CREES EN FONCTION DU MOT CLE MAIS JE NE SAIS PAS COMMENT LES APPELER ICI
  74.                             With Worksheets(F)
  75.     'On définit la ligne où sera effectué le collage
  76.                             Ligne = .Range("A" & Rows.Count).End(xlUp).Row + 1
  77.     'On effectue le copier / coller
  78.                             c.EntireRow.Copy .Range("A" & Ligne)
  79.     'On supprime la ligne dans la sheet1
  80.                             c.EntireRow.Delete
  81.                             End With
  82.                         End If
  83.                         Loop While Not c Is Nothing
  84.                     Next i
  86. End Sub


Reply

Sujets relatifs:

Leave a Replay

Make sure you enter the(*)required information where indicate.HTML code is not allowed