Sto cercando di costruire una cartella di lavoro principale chericeve un dump mensile di dati per tutti i centri di costo che popoleranno quindi un gran numero di fogli di lavoro all'interno della cartella di lavoro e che dovranno quindi essere suddivisi e inviati ai responsabili dell'assistenza. Un responsabile del servizio riceverà una selezione di fogli di lavoro in base ai primi 4 caratteri del nome del foglio (sebbene ciò possa cambiare a tempo debito).
ad es. 1234x, 1234y, 5678a, 5678b produrranno due nuove cartelle di lavoro denominate 1234 e 5678 con due fogli ciascuna.
Ho messo insieme alcuni codici da vari forum acreare una macro che funzionerà attraverso un array hard coded che definisce i codici carattere della testa di servizio 4 e creare una serie di nuove cartelle di lavoro. E che sembra funzionare.
Tuttavia.. Devo anche includere il foglio di dump dei dati principali nel file di origine (chiamato "dati") con l'array di file da copiare in modo che i collegamenti rimangano con il foglio di dati da copiare. Se scrivo una riga da copiare separatamente sul foglio dati, la nuova cartella di lavoro fa ancora riferimento al file di origine, a cui i responsabili del servizio non hanno accesso.
Quindi la domanda principale è: come posso aggiungere la scheda "dati" in Fogli (CopyNames) .Copia il codice in modo che venga copiato con tutti gli altri file nell'array allo stesso per mantenere intatti i collegamenti?
La seconda domanda è se decido che è la primadue caratteri del foglio di lavoro definiscono i fogli che si riferiscono a una testina di servizio, come posso modificare la linea di divisione / metà del codice - ho provato ma mi sto annodando!
Qualsiasi altro consiglio per rendere il codice più eleganteapprezzato (potrebbe esserci un elenco piuttosto lungo di codici head di servizio e sono sicuro che esiste un modo migliore di creare un elenco per il loop della routine)
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
risposte:
0 per risposta № 1Option 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 testato e scritto su dispositivo mobile, mi dispiace per la formattazione errata.
Questo approccio propone di archiviare tutti i servizicodici head in una tabella Excel a 1 colonna su un foglio dedicato a cui si fa riferimento tramite la nomenclatura della tabella Excel (che potrebbe essere più semplice di ArrayList.Add per ogni nuovo codice head del servizio).
Presumo che il codice sia memorizzato nella cartella di lavoro principale ("questa cartella di lavoro"), che potrebbe non essere vera.
È possibile modificare la tabella dei codici di serviziodirettamente sul foglio di calcolo stesso, se successivamente decidi che SheetsToCopy sarà determinato dai primi 2, 3 o X caratteri o potresti modificare l'array stesso con la funzione $ () sinistra.
Spero che funzioni o ti dia qualche idea.
Modificare: Questo è il mio layout di foglio e tabella (che presumo corrisponda al tuo).
E questo è ciò che il codice sopra mi dà sul mio computer.
