Копіювання базового аркуша даних разом із вибраними аркушами з вихідної робочої книги до нової робочої книги - excel, vba

Я дивлюся на створення головного робочого зошита, якийщомісяця отримує дамп даних для всіх центрів витрат, які потім заповнюватимуть велику кількість робочих аркушів у робочій книжці, які потім потрібно розділити та відправити керівникам служб. Керівник служби отримає підбірку робочих таблиць на основі перших 4 символів назви аркуша (хоча це може змінитися з часом).

наприклад, 1234x, 1234y, 5678a, 5678b буде створено дві нові робочі зошити під назвою 1234 та 5678 з двома аркушами в кожному.

Я створив якийсь код з різних форумів настворити макрос, який буде працювати через важко закодований масив, визначаючи коди символів 4-го сервісного коду та створити ряд нових робочих книжок. І який, здається, працює.

Однак .. Мені також потрібно включити основний аркуш дампа даних у вихідний файл (званий "дані") з масивом файлів, які копіюються, щоб посилання залишалися з копіюваним аркушем даних. Якщо я напишу рядок для копіювання над аркушем даних окремо, нова робоча книга все одно повертається до вихідного файлу, до якого сервісні служби не мають доступу.

Отже, головне питання: як я можу додати вкладку "data" у таблиці (CopyNames).

Друге питання - якщо я вирішу, що це першедва символи робочого аркуша визначають аркуші, які відносяться до служби обслуговування, як я підкручую розділений / середній рядок коду - я пробував навколо себе, але я зав'язуюся у вузли!

Будь-які інші поради, щоб зробити код більш елегантнимоцінено (може бути досить довгий список кодів службових служб, і я впевнений, що є кращий спосіб створити список для рутинної перевірки)

    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

Відповіді:

0 для відповіді № 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

Не перевірений і написаний на мобільному пристрої, вибачте за неправильне форматування.

Цей підхід пропонує зберігати всі послугикоди заголовка в 1-колонковій таблиці Excel на спеціальному аркуші, на який посилається через номенклатуру таблиць Excel (що може бути простіше, ніж ArrayList.Add для кожного нового коду заголовка служби).

Я припускаю, що код зберігається в головній робочій книзі ("цій роботі"), що може бути неправдивим.

Ви можете змінити таблицю службових кодівбезпосередньо на самій електронній таблиці, якщо згодом ви вирішите, що SheetsToCopy визначатиметься першими 2, 3 або X символами - або ви можете змінити масив з лівою функцією $ ().

Сподіваюся, це спрацює або дасть вам кілька ідей.

Редагувати: Це мій аркуш та таблиця (який, мабуть, відповідає вашому).

І це те, що наведений вище код на моєму комп’ютері.

---