copier-coller cellules fusionnées depuis un TCD

copier-coller cellules fusionnées depuis un TCD - VB/VBA/VBS - Programmation

Marsh Posté le 04-06-2023 à 08:39:14    

Bonjour, je vous fais un résumé:
Créer une macro pour Office Excel 2021 Français pour :
1. Importer les cellules fusionnées en conservant leur format exact (nom, dimension, couleur, bordures et aussi les commentaires) suivant la liste dans le Tableau Croisé Dynamique « TOUS_BATIMENTS » depuis la colonne « Etiquettes de lignes »
2. Les cellules fusionnées qui doivent être importées se trouvent dans la feuille: « BATIMENTS » et les recopier dans la feuille «VOTRE_CITE» à partir de la colonne « CT »
Exemple : si dans le TCD « TOUS_BATIMENTS » est écrit « antre de voyous « dans la colonne « Etiquettes de lignes » et « 2 » dans la colonne « Quantités », importer deux fois les cellules fusionnées correspondant se trouvant dans la feuille « BATIMENTS»
3. Importer les cellules fusionnées en conservant leur format exact (nom, dimension, couleur, bordures et aussi les commentaires) suivant la liste dans le Tableau Croisé Dynamique « T_GM», les cellules fusionnées à importer se trouvant dans la feuille «GM Implantation», il n’y aura qu’un seul exemplaire de chaque pour ce tableau croisé dynamique « T_GM », aucun doublon ne sera possible.
4. Recopier les cellules fusionnées à partir de la colonne « CT » de la feuille « VOTRE_CITE » sans que les cellules ne se chevauchent en conservant leur format (nom, dimension, couleur, bordures et aussi les commentaires)  
5. Prendre en compte la fonction « CopierCellulesFusionnees »
6. Tenir compte des quantités dans le tableau croisé dynamique "TOUS_BATIMENTS".
Cette macro est destinée pour aider dans le jeu "Forge of Empire" afin de pouvoir remanier sa cité. J'aimerai automatiser le fait de copier-coller les cellules fusionnées représentant les divers bâtiments lors du remaniement de sa cité. J'ai déjà réalisé les cellules fusionnées représentant tous les bâtiments rangées par catégories (regroupées pour faciliter la mise en place du remaniement) mais lorsque je lance ma macro aucune cellules fusionnées n'est recopiée dans une feuille dédiée avec un emplacement réservé au stockage des dits bâtiments. Ensuite le joueur n'aura plus qu'à se creuser la tête afin de trouver la meilleure implantation de ses bâtiments pour optimiser la place.Merci déjà d'avoir pris le temps à la lecture et à ceux qui ont les connaissances afin de m' apporter leur aide. Je précise que je n' ai aucune connaissance en programmation et que c'est la première (je sais, j'ai un pet au casque de me lancer là-dedans).Je peux joindre le classeur si besoin...(me dire comment procéder  :(  

Code :
  1. Sub ImporterCellulesFusionnees()
  2.     Dim wsCite As Worksheet
  3.     Dim wsCulturel As Worksheet, wsMarchandise As Worksheet, wsProduction As Worksheet
  4.     Dim wsEnsembles As Worksheet, wsMilitaire As Worksheet, wsResidentiel As Worksheet
  5.     Dim wsSpeciaux As Worksheet, wsDecoration As Worksheet, wsGMImplantation As Worksheet
  6.     Dim wsGM As Worksheet
  7.     Dim pivotTousBatiments As PivotTable, pivotGM As PivotTable
  8.     Dim rng As Range
  9.     Dim etiquettes As Range
  10.     Dim quantites As Range
  11.     Dim nomEtiquette As String
  12.     Dim quantite As Integer
  13.     Dim destination As Range
  14.     Dim fusionnees As Range
  15.    
  16.     ' Références aux feuilles de calcul
  17.     Set wsCite = ThisWorkbook.sheets("VOTRE_CITE" )
  18.     Set wsCulturel = ThisWorkbook.sheets("CULTUREL" )
  19.     Set wsMarchandise = ThisWorkbook.sheets("MARCHANDISE" )
  20.     Set wsProduction = ThisWorkbook.sheets("PRODUCTION" )
  21.     Set wsEnsembles = ThisWorkbook.sheets("ENSEMBLES" )
  22.     Set wsMilitaire = ThisWorkbook.sheets("MILITAIRE" )
  23.     Set wsResidentiel = ThisWorkbook.sheets("RESIDENTIEL" )
  24.     Set wsSpeciaux = ThisWorkbook.sheets("SPECIAUX" )
  25.     Set wsDecoration = ThisWorkbook.sheets("DECORATION" )
  26.     Set wsGMImplantation = ThisWorkbook.sheets("GM Implantation" )
  27.    
  28.    
  29.     ' Référence au tableau croisé dynamique "TOUS BATIMENTS" dans la feuille "VOTRE_CITE"
  30.     Set pivotTousBatiments = wsCite.PivotTables("TOUS BATIMENTS" )
  31.    
  32.     ' Référence au tableau croisé dynamique "GM" dans la feuille "VOTRE_CITE"
  33.     Set pivotGM = wsCite.PivotTables("GM" )
  34.    
  35.     ' Vider la plage de destination
  36.     wsCite.Range("CA2:ZZ95" ).ClearContents
  37.    
  38.     ' Importer les cellules fusionnées du tableau "TOUS BATIMENTS"
  39.     For Each etiquettes In pivotTousBatiments.RowRange
  40.         nomEtiquette = etiquettes.Cells(1).Value
  41.        
  42.         On Error Resume Next
  43.                 quantite = Application.WorksheetFunction.Match(nomEtiquette, pivotTousBatiments.ColumnRange, 0)
  44.         On Error GoTo 0
  45.        
  46.         If quantite <> 0 Then
  47.             Set quantites = pivotTousBatiments.ColumnRange.Cells(quantite)
  48.            
  49.             ' Importer les cellules fusionnées de chaque feuille correspondante
  50.             Set destination = wsCite.Range("CA2" ).End(xlDown).Offset(1)
  51.            
  52.             ' Copier les cellules fusionnées de la feuille "CULTUREL"
  53.             Set wsGM = ThisWorkbook.sheets("CULTUREL" )
  54.             For Each fusionnees In wsCulturel.Cells.SpecialCells(xlCellTypeConstants)
  55.                 fusionnees.Copy destination
  56.                 Set destination = destination.Offset(fusionnees.Rows.Count)
  57.                
  58.                 ' Afficher un message de débogage
  59.                 MsgBox "Copie effectuée pour la cellule fusionnée de la feuille CULTUREL : " & fusionnees.Address
  60.             Next fusionnees
  61.            
  62.             ' Copier les cellules fusionnées de la feuille "MARCHANDISE"
  63.             Set wsGM = ThisWorkbook.sheets("MARCHANDISE" )
  64.             For Each fusionnees In wsMarchandise.UsedRange.SpecialCells(xlCellTypeConstants)
  65.                 fusionnees.Copy destination
  66.                 Set destination = destination.Offset(fusionnees.Rows.Count)
  67.                
  68.                 ' Afficher un message de débogage
  69.                 MsgBox "Copie effectuée pour la cellule fusionnée de la feuille MARCHANDISE : " & fusionnees.Address
  70.             Next fusionnees
  71.            
  72.             ' Copier les cellules fusionnées de la feuille "PRODUCTION"
  73.             Set wsGM = ThisWorkbook.sheets("PRODUCTION" )
  74.             For Each fusionnees In wsProduction.UsedRange.SpecialCells(xlCellTypeConstants)
  75.                 fusionnees.Copy destination
  76.                 Set destination = destination.Offset(fusionnees.Rows.Count)
  77.                
  78.                 ' Afficher un message de débogage
  79.                 MsgBox "Copie effectuée pour la cellule fusionnée de la feuille PRODUCTION : " & fusionnees.Address
  80.             Next fusionnees
  81.            
  82.             ' Copier les cellules fusionnées de la feuille "ENSEMBLES"
  83.             Set wsGM = ThisWorkbook.sheets("ENSEMBLES" )
  84.             For Each fusionnees In wsEnsembles.UsedRange.SpecialCells(xlCellTypeConstants)
  85.                 fusionnees.Copy destination
  86.                 Set destination = destination.Offset(fusionnees.Rows.Count)
  87.                
  88.                 ' Afficher un message de débogage
  89.                 MsgBox "Copie effectuée pour la cellule fusionnée de la feuille ENSEMBLES : " & fusionnees.Address
  90.             Next fusionnees
  91.            
  92.             ' Copier les cellules fusionnées de la feuille "MILITAIRE"
  93.             Set wsGM = ThisWorkbook.sheets("MILITAIRE" )
  94.             For Each fusionnees In wsMilitaire.UsedRange.SpecialCells(xlCellTypeConstants)
  95.                 fusionnees.Copy destination
  96.                 Set destination = destination.Offset(fusionnees.Rows.Count)
  97.                
  98.                 ' Afficher un message de débogage
  99.                 MsgBox "Copie effectuée pour la cellule fusionnée de la feuille MILITAIRE : " & fusionnees.Address
  100.             Next fusionnees
  101.            
  102.             ' Copier les cellules fusionnées de la feuille "RESIDENTIEL"
  103.             Set wsGM = ThisWorkbook.sheets("RESIDENTIEL" )
  104.             For Each fusionnees In wsResidentiel.UsedRange.SpecialCells(xlCellTypeConstants)
  105.                 fusionnees.Copy destination
  106.                 Set destination = destination.Offset(fusionnees.Rows.Count)
  107.                
  108.                 ' Afficher un message de débogage
  109.                 MsgBox "Copie effectuée pour la cellule fusionnée de la feuille RESIDENTIEL : " & fusionnees.Address
  110.             Next fusionnees
  111.            
  112.                             ' Copier les cellules fusionnées de la feuille "SPECIAUX"
  113.             Set wsGM = ThisWorkbook.sheets("SPECIAUX" )
  114.             For Each fusionnees In wsSpeciaux.UsedRange.SpecialCells(xlCellTypeConstants)
  115.                 fusionnees.Copy destination
  116.                 Set destination = destination.Offset(fusionnees.Rows.Count)
  117.                
  118.                 ' Afficher un message de débogage
  119.                 MsgBox "Copie effectuée pour la cellule fusionnée de la feuille SPECIAUX : " & fusionnees.Address
  120.             Next fusionnees
  121.            
  122.             ' Copier les cellules fusionnées de la feuille "DECORATION"
  123.             Set wsGM = ThisWorkbook.sheets("DECORATION" )
  124.             For Each fusionnees In wsDecoration.UsedRange.SpecialCells(xlCellTypeConstants)
  125.                 fusionnees.Copy destination
  126.                 Set destination = destination.Offset(fusionnees.Rows.Count)
  127.                
  128.                 ' Afficher un message de débogage
  129.                 MsgBox "Copie effectuée pour la cellule fusionnée de la feuille DECORATION : " & fusionnees.Address
  130.             Next fusionnees
  131.            
  132.             ' Copier les cellules fusionnées de la feuille "GM IMPLANTATION"
  133.             Set wsGM = ThisWorkbook.sheets("GM_Implantation" )
  134.             For Each fusionnees In wsGMImplantation.UsedRange.SpecialCells(xlCellTypeConstants)
  135.                 fusionnees.Copy destination
  136.                 Set destination = destination.Offset(fusionnees.Rows.Count)
  137.                
  138.                 ' Afficher un message de débogage
  139.                 MsgBox "Copie effectuée pour la cellule fusionnée de la feuille GM IMPLANTATION : " & fusionnees.Address
  140.             Next fusionnees
  141.            
  142.         End If
  143.     Next etiquettes
  144.    
  145.     MsgBox "Importation des cellules fusionnées terminée avec succès !"
  146. End Sub


Reply

Marsh Posté le 04-06-2023 à 08:39:14   

Reply

Sujets relatifs:

Leave a Replay

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