/ / Kopieren des Basisdatenblatts zusammen mit ausgewählten Blättern aus der Quellarbeitsmappe in eine neue Arbeitsmappe - excel, vba

Kopieren des Basisdatenblatts zusammen mit ausgewählten Blättern aus der Quellarbeitsmappe in eine neue Arbeitsmappe - excel, vba

Ich möchte ein Master-Arbeitsbuch erstellen, daserhält einen monatlichen Datenauszug für alle Kostenstellen, der dann eine große Anzahl von Arbeitsblättern in der Arbeitsmappe auffüllt und dann aufgeteilt und an die Serviceleiter gesendet werden muss. Ein Serviceleiter erhält eine Auswahl von Arbeitsblättern basierend auf den ersten 4 Zeichen des Blattnamens (obwohl sich dies zu gegebener Zeit ändern kann).

Beispiel: 1234x, 1234y, 5678a, 5678b erzeugen zwei neue Arbeitsmappen mit den Namen 1234 und 5678 mit jeweils zwei Blättern.

Ich habe Code aus verschiedenen Foren gepflastertErstellen Sie ein Makro, das ein fest codiertes Array durchläuft, das die 4-Zeichen-Codes des Servicekopfs definiert, und erstellen Sie eine Reihe neuer Arbeitsmappen. Und das scheint zu funktionieren.

Jedoch.. Ich muss auch das Hauptdaten-Dump-Blatt in die Quelldatei ("Daten" genannt) mit dem Array der zu kopierenden Dateien aufnehmen, damit die Verknüpfungen mit dem zu kopierenden Datenblatt erhalten bleiben. Wenn ich eine Zeile schreibe, um das Datenblatt separat zu kopieren, verweist die neue Arbeitsmappe immer noch auf die Quelldatei, auf die die Service-Heads keinen Zugriff haben.

Die Hauptfrage lautet also: Wie kann ich die Registerkarte "Daten" zu den Blättern (CopyNames) hinzufügen. Kopiercode, damit er mit allen anderen Dateien im Array gleichzeitig kopiert wird, um die Links intakt zu halten?

Die zweite Frage ist, ob ich mich für die erste entscheideZwei Zeichen des Arbeitsblatts definieren die Blätter, die sich auf einen Servicekopf beziehen. Wie kann ich die geteilte / mittlere Codezeile optimieren? Ich habe es ausprobiert, bin aber in Knoten gefesselt!

Alle anderen Tipps, um den Code viel eleganter zu machengeschätzt (es kann eine ziemlich lange Liste von Service-Head-Codes geben und ich bin sicher, dass es eine bessere Möglichkeit gibt, eine Liste zu erstellen, durch die die Routine eine Schleife durchlaufen kann)

    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

Antworten:

0 für die Antwort № 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

Ungetestet und auf dem Handy geschrieben, entschuldigen Sie die schlechte Formatierung.

Dieser Ansatz schlägt vor, dass Sie alle Dienste speichernKopfcodes in einer einspaltigen Excel-Tabelle auf einem dedizierten Blatt, auf das über die Excel-Tabellennomenklatur verwiesen wird (was möglicherweise einfacher als ArrayList.Add für jeden neuen Service-Kopfcode ist).

Ich gehe davon aus, dass Code in der Master-Arbeitsmappe ("diese Arbeitsmappe") gespeichert ist, was möglicherweise nicht der Fall ist.

Sie können die Tabelle mit den Servicekopfcodes änderndirekt in der Tabelle selbst, wenn Sie später entscheiden, dass SheetsToCopy durch die ersten 2, 3 oder X Zeichen bestimmt wird - oder Sie können das Array selbst mit der Funktion left $ () ändern.

Hoffe es funktioniert oder gibt Ihnen einige Ideen.

Bearbeiten: Dies ist mein Blatt- und Tabellenlayout (von dem ich annehme, dass es mit Ihrem übereinstimmt).

Blatt- und Tischstruktur

Und das gibt mir der obige Code auf meinem Computer.

Ausgabedateien