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)
  12.     'On définit les mots clés
  13.     MotCle = Array("aaa", "bbb", "ccc", "ddd" )
  14.     'On effectue la recherche de chaque mot clé dans la colonne A de la sheet1
  15.     For i = 0 To UBound(MotCle)
  16.         Do
  17.             Set C = Worksheets("sheet1 (2)" ).Columns(1).Find(MotCle(i), LookIn:=xlValues, lookat:=xlPart)
  18.             If Not C Is Nothing Then
  19.             F = "sheet" & (i + 2)
  20.             With Worksheets(F)
  21.             'On définit la ligne où sera effectué le collage
  22.             Ligne = .Range("F" & Rows.Count).End(xlUp).Row + 1
  23.             'On effectue le copier / coller
  24.             C.EntireRow.Copy .Range("A" & Ligne)
  25.             'On supprime la ligne dans la sheet1(2)
  26.             C.EntireRow.Delete
  27.             End With
  28.             End If
  29.         Loop While Not C Is Nothing
  30.     Next i
  31.     'On renomme les feuilles
  32.     Worksheets("sheet2" ).Name = "aaa"
  33.     Worksheets("sheet3" ).Name = "bbb"
  34.     Worksheets("sheet4" ).Name = "ccc"
  35.     Worksheets("sheet5" ).Name = "ddd"
  36. 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()
  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. Dim Nom As String
  9. Dim d As Range
  10. Dim n As Byte
  11. Const lideb = 1
  12. Const lifin = 30
  13. Dim plage As Range
  14. Dim li As Long
  15.     'On supprime toutes données dans la feuille MonthsExtract
  16.         Worksheets("MonthsExtract" ).Range("A1:A65536" ).ClearContents
  17.     'On supprime la sheet1 (2) qui est la copie des données d'origines
  18.         On Error Resume Next
  19.             Application.DisplayAlerts = False
  20.             Sheets("sheet1 (2)" ).Delete
  21.             Application.DisplayAlerts = True
  22.    'On copie la feuille de données
  23.             a = Sheets.Count
  24.             Sheets("sheet1" ).Select
  25.             Sheets("sheet1" ).Copy After:=Sheets(a)
  26.     'On copie les mois existants en supprimant les doublons dans un onglet MonthsExtract
  27.             Range("A11:A" & Range("A65536" ).End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Worksheets("MonthsExtract" ).Range("A1" ), Unique:=True
  28.             With ThisWorkbook.Worksheets("MonthsExtract" ).Range("A1" )
  29.                 If .Value = "(%)" Then .EntireRow.Delete
  30.             End With
  31.     'On crée nouvelle feuille pour chaque mois existant
  32.             With ActiveSheet.Name = Sheets("MonthsExtract" )
  33.                 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
  34.                 Sheets.Add
  35.                 ActiveSheet.Name = Sheets("MonthsExtract" ).Range("A" & li)
  36.                 plage.Copy .Range("A" & li)
  37.                 Next li
  38.             End With
  39.             Application.DisplayAlerts = False 'deactive les messages autorisation d'effacer
  40.             For Each Sh In Sheets
  41.     'On supprime les feuilles qui commencent par Feuil
  42.             If Left(Sh.Name, 5) = "Feuil" Then Sh.Delete
  43.             Next
  44.             Application.DisplayAlerts = True 'reactive les messages autorisation d'effacer
  45.     'On copie les entetes
  46.   '         For Each Sh In Worksheets
  47.                 Sheets("sheet1" ).Range("A7:Z11" ).Copy
  48.                 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 ?
  49.                 Sheets("APR 2018" ).Range("A1" ).PasteSpecial Paste:=xlPasteFormats
  50.     'On définit les mots clés
  51.                 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" )
  52.     'On effectue la recherche de chaque mot clé dans la colonne A de la sheet1
  53.                 For i = 0 To UBound(MotCle)
  54.                     Do
  55.                         Set c = Worksheets("sheet1 (2)" ).Columns(1).Find(MotCle(i), LookIn:=xlValues, lookat:=xlPart)
  56.     'Si le mot clé est trouvé
  57.                         If Not c Is Nothing Then
  58.     'On définit le nom de la feuille où sera effectuée la copie
  59.                         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
  60.                             With Worksheets(F)
  61.     'On définit la ligne où sera effectué le collage
  62.                             Ligne = .Range("A" & Rows.Count).End(xlUp).Row + 1
  63.     'On effectue le copier / coller
  64.                             c.EntireRow.Copy .Range("A" & Ligne)
  65.     'On supprime la ligne dans la sheet1
  66.                             c.EntireRow.Delete
  67.                             End With
  68.                         End If
  69.                         Loop While Not c Is Nothing
  70.                     Next i
  71. End Sub


Reply

Sujets relatifs:

Leave a Replay

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