/ / Kopiowanie podstawowego arkusza danych wraz z wybranymi arkuszami ze skoroszytu źródłowego do nowego skoroszytu - excel, vba

Kopiowanie podstawowego arkusza danych wraz z wybranymi arkuszami ze skoroszytu źródłowego do nowego skoroszytu - excel, vba

Patrzę na budowę podręcznika, któryotrzymuje comiesięczny zrzut danych dla wszystkich centrów kosztów, które następnie wypełniają dużą liczbę arkuszy w skoroszycie, a następnie muszą zostać rozdzielone i wysłane do szefów służb. Kierownik serwisu otrzyma wybór arkuszy na podstawie pierwszych 4 znaków nazwy arkusza (chociaż może się to zmienić w odpowiednim czasie).

np. 1234x, 1234y, 5678a, 5678b wytworzą dwa nowe skoroszyty o nazwach 1234 i 5678 z dwoma arkuszami w każdym.

Przygotowałem jakiś kod z różnych forówutwórz makro, które będzie działało poprzez zakodowaną tablicę definiującą kody usług 4 znaków i utwórz serię nowych skoroszytów. I który wydaje się działać.

Jednak.. Muszę także dołączyć główny plik zrzutu danych do pliku źródłowego (zwanego „danymi”), tak aby tablica plików była kopiowana, tak aby łącza pozostały przy kopiowaniu arkusza danych. Jeśli piszę wiersz, aby skopiować osobno arkusz danych, nowy skoroszyt nadal odsyła do pliku źródłowego, do którego nie mają dostępu głowice usług.

Więc główne pytanie brzmi: jak mogę dodać kartę „dane” do arkuszy (CopyNames) .Kopiować kod, aby został skopiowany wraz z wszystkimi innymi plikami w tablicy, aby zachować nienaruszone łącza?

Drugie pytanie dotyczy tego, czy zdecyduję, że to pierwszedwie postacie arkusza definiują arkusze odnoszące się do głowicy serwisowej, jak mam ulepszyć linię kodu dzielonego / środkowego - sprawdziłem się, ale jestem związany w węzłach!

Wszelkie inne wskazówki, aby kod był bardziej eleganckidoceniony (może być dość długa lista kodów głowic serwisowych i jestem pewien, że istnieje lepszy sposób na utworzenie listy dla procedury do przechodzenia)

    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

Odpowiedzi:

0 dla odpowiedzi № 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

Nietestowane i napisane na telefonie komórkowym, przepraszam za złe formatowanie.

Takie podejście proponuje przechowywanie wszystkich usługkody głowy w 1-kolumnowej tabeli Excel na dedykowanym arkuszu, do którego odwołuje się nomenklatura tabeli Excel (która może być łatwiejsza niż ArrayList.Add dla każdego nowego kodu głowicy usługi).

Zakładam, że kod jest przechowywany w głównym skoroszycie („thisworkbook”), co może nie być prawdą.

Możesz zmodyfikować tabelę serviceheadcodesbezpośrednio w arkuszu kalkulacyjnym, jeśli później zdecydujesz, że SheetsToCopy zostanie określona przez pierwsze 2, 3 lub X znaków - lub możesz zmodyfikować samą tablicę za pomocą lewej funkcji $ ().

Mam nadzieję, że działa lub daje kilka pomysłów.

Edytować: To jest mój układ arkuszy i tabel (który zakładam, że pasuje do Ciebie).

Struktura arkuszy i tabel

I to właśnie daje mi powyższy kod na moim komputerze.

Pliki wyjściowe