/ / Copie de la feuille de données de base avec les feuilles sélectionnées du classeur source vers le nouveau classeur - Excel, VBA

Copie de la feuille de données de base avec les feuilles sélectionnées du classeur source vers le nouveau classeur - Excel, VBA

Je cherche à construire un classeur maître quireçoit un vidage mensuel de données pour tous les centres de coûts, qui remplira ensuite un grand nombre de feuilles de calcul dans le classeur, et qui devra ensuite être séparé et envoyé aux chefs de service. Un chef de service recevra une sélection de feuilles de calcul en fonction des 4 premiers caractères du nom de la feuille (bien que cela puisse changer en temps voulu).

Par exemple, 1234x, 1234y, 5678a, 5678b produira deux nouveaux classeurs nommés 1234 et 5678 avec chacun deux feuilles.

J'ai bricolé du code provenant de divers forums pourcréer une macro qui fonctionnera à travers un tableau codé en dur définissant les codes à 4 caractères de la tête de service et créer une série de nouveaux classeurs. Et qui semble fonctionner.

Pourtant.. J'ai également besoin d'inclure la feuille de vidage de données principale dans le fichier source (appelé "données") avec le tableau de fichiers copiés afin que les liens restent avec la feuille de données copiée. Si j'écris une ligne à copier sur la fiche technique séparément, le nouveau classeur fait toujours référence au fichier source, auquel les chefs de service n'ont pas accès.

Donc, la question principale est: comment puis-je ajouter l'onglet "données" dans le code Sheets (CopyNames) .Copy afin qu'il soit copié avec tous les autres fichiers du tableau en même temps pour garder les liens intacts?

La deuxième question est de savoir si je décide que c'est la premièredeux caractères de la feuille de calcul définissent les feuilles qui se rapportent à une tête de service, comment puis-je modifier la ligne de code fractionnée / intermédiaire - j'ai essayé, mais je suis lié par des nœuds!

Tous les autres conseils pour rendre le code plus élégantapprécié (il peut y avoir une longue liste de codes de tête de service et je suis sûr qu'il existe un meilleur moyen de créer une liste pour la routine à parcourir)

    Sub Copy_Sheets()
Dim strNames As String, strWSName As String
Dim arrNames, CopyNames
Dim wbAct As Workbook
Dim i As Long
Dim arrlist As Object

Set arrlist = CreateObject("system.collections.arraylist")
arrlist.Add "1234"
arrlist.Add "5678"


Set wbAct = ActiveWorkbook
For Each Item In arrlist

For i = 1 To Sheets.Count
strNames = strNames & "," & Sheets(i).Name
Next i
arrNames = Split(Mid(strNames, 2), ",")

"strWSName =("1234")
strWSName = Item

Application.ScreenUpdating = False
CopyNames = Filter(arrNames, strWSName, True, vbTextCompare)
If UBound(CopyNames) > -1 Then
Sheets(CopyNames).Copy
ActiveWorkbook.SaveAs Filename:=strWSName & " " & Format(Now, "dd-mmm-yy h-mm-ss")
ActiveWorkbook.Close
wbAct.Activate
Else
MsgBox "No sheets found: " & strWSName
End If

Next Item

Application.ScreenUpdating = True

End Sub

Réponses:

0 pour la réponse № 1
Option Explicit

Sub CopySheets()

With ThisWorkbook

Dim SheetIndex As Long
Dim ValidSheetNames() As String
ReDim ValidSheetNames(1 To .Worksheets.Count)

" Build a 1 dimensional array called ValidSheetNames, which contains every sheet in the master workbook other than DEDICATEDSHEET. "
Dim ws As Worksheet
For Each ws In .Worksheets
If ws.Name <> "DEDICATEDSHEET" Then
SheetIndex = SheetIndex + 1
ValidSheetNames(SheetIndex) = ws.Name
End If
Next ws
ReDim Preserve ValidSheetNames(1 To SheetIndex)

" Read all ServiceCodes into a 1-dimensional array "
Dim ServiceHeadCodes As Variant
ServiceHeadCodes = Application.Transpose(.Worksheets("DEDICATEDSHEET").Range("CCLIST[CC]").Value2)

Dim CodeIndex As Long

" Now loop through each ServiceHeadCode "
For CodeIndex = LBound(ServiceHeadCodes) To UBound(ServiceHeadCodes)

" Put all sheet names which contain the current ServiceHeadCode into an array called SheetsToCopy "
Dim SheetsToCopy() As String
SheetsToCopy = Filter(ValidSheetNames, ServiceHeadCodes(CodeIndex), True, vbTextCompare)

" Check if SheetToCopy now contains any sheet names at all. "
If UBound(SheetsToCopy) > -1 Then

" Add the name of the Data sheet to the end of the array "
ReDim Preserve SheetsToCopy(LBound(SheetsToCopy) To (UBound(SheetsToCopy) + 1))
SheetsToCopy(UBound(SheetsToCopy)) = "Data"


Dim OutputWorkbook As Workbook
Set OutputWorkbook = Application.Workbooks.Add

" Copy all sheets which are in SheetToCopy array to newly created OutputWorkbook "
.Worksheets(SheetsToCopy).Copy OutputWorkbook.Worksheets(1)

" Delete the default Sheet1, which should be at the end as copied sheets were inserted before it. "
" But suppress the Are you sure you want to delete this sheet.. message. "
Application.DisplayAlerts = False
OutputWorkbook.Worksheets(OutputWorkbook.Worksheets.Count).Delete
Application.DisplayAlerts = True
" Re-enable alerts, as we want to see any other dialogue boxes/messages

" Not providing a full directory path below means OutputWorkbook will be saved wherever Thisworkbook is saved."
OutputWorkbook.SaveAs Filename:=ServiceHeadCodes(CodeIndex) & " " & Format(Now, "dd-mmm-yy h-mm-ss") & ".xlsx", FileFormat:=51
OutputWorkbook.Close
Else
MsgBox "No sheets found: " & ServiceHeadCodes(CodeIndex)
End If

Next CodeIndex

End With

End Sub

Non testé et écrit sur mobile, désolé pour un mauvais formatage.

Cette approche vous propose de stocker tous les servicescodes d'en-tête dans un tableau Excel à 1 colonne sur une feuille dédiée à laquelle il est fait référence via la nomenclature du tableau Excel (ce qui pourrait être plus facile que ArrayList.Add pour chaque nouveau code d'en-tête de service).

Je suppose que le code est stocké dans le classeur principal ("ce classeur"), ce qui n'est peut-être pas vrai.

Vous pouvez modifier la table des codes de servicedirectement sur la feuille de calcul elle-même, si vous décidez plus tard que SheetsToCopy sera déterminé par les 2, 3 ou X premiers caractères - ou vous pouvez modifier le tableau lui-même avec la fonction $ () gauche.

J'espère que cela fonctionne ou vous donne quelques idées.

Modifier: Ceci est ma disposition de feuille et de table (qui je suppose correspond à la vôtre).

Structure de feuille et de table

Et c'est ce que le code ci-dessus me donne sur mon ordinateur.

Fichiers de sortie