/ / Cópia da folha de dados de base juntamente com as folhas selecionadas da pasta de trabalho de origem para a nova pasta de trabalho - excel, vba

Copiando a folha de dados de base junto com as folhas selecionadas da pasta de trabalho de origem para a nova pasta de trabalho - excel, vba

Estou pensando em criar uma pasta de trabalho principal querecebe um despejo mensal de dados para todos os centros de custo, que preencherão um grande número de planilhas na pasta de trabalho e que precisarão ser divididos e enviados aos chefes de serviço. Um chefe de serviço receberá uma seleção de planilhas com base nos 4 primeiros caracteres do nome da planilha (embora isso possa mudar no devido tempo).

por exemplo, 1234x, 1234y, 5678a, 5678b produzirá duas novas pastas de trabalho denominadas 1234 e 5678 com duas folhas em cada uma.

Eu cobbled algum código de vários fóruns paracrie uma macro que funcione através de uma matriz codificada que define os códigos de 4 caracteres da cabeça de serviço e crie uma série de novas pastas de trabalho. E o que parece funcionar.

Contudo.. Também preciso incluir a planilha de despejo de dados principal no arquivo de origem (chamado "dados") com a matriz de arquivos sendo copiados para que os links permaneçam com a planilha de dados copiada. Se eu escrever uma linha para copiar a planilha de dados separadamente, a nova pasta de trabalho ainda se refere ao arquivo de origem, ao qual os chefes de serviço não têm acesso.

Portanto, a questão principal é: como posso adicionar a guia "data" ao Sheets (CopyNames). Copie o código para que ele seja copiado com todos os outros arquivos da matriz ao mesmo tempo para manter os links intactos?

A segunda pergunta é se eu decidir que é a primeiradois caracteres da planilha definem as planilhas relacionadas a um chefe de serviço, como faço para ajustar a linha de código dividida / média - experimentei, mas estou ficando empolgado!

Quaisquer outras dicas para tornar o código mais eleganteapreciado (pode haver uma lista bastante longa de códigos de cabeça de serviço e tenho certeza de que há uma maneira melhor de criar uma lista para a rotina percorrer)

    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

Respostas:

0 para resposta № 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

Não testado e escrito no celular, desculpe pela formatação incorreta.

Essa abordagem propõe que você armazene todos os serviçoscódigos de cabeçalho em uma tabela do Excel de uma coluna em uma planilha mencionada pela nomenclatura da tabela do Excel (que pode ser mais fácil que ArrayList.Add para cada novo código de cabeçalho de serviço).

Presumo que o código esteja armazenado na pasta de trabalho principal ("thisworkbook"), o que pode não ser verdadeiro.

Você pode modificar a tabela serviceheadcodesdiretamente na própria planilha, se você decidir posteriormente que o SheetsToCopy será determinado pelos primeiros 2, 3 ou X caracteres - ou poderá modificar a própria matriz com a função esquerda $ ().

Espero que funcione ou lhe dê algumas idéias.

Editar: Este é o meu layout de planilha e tabela (que eu assumo coincidir com o seu).

Estrutura de folhas e tabelas

E é isso que o código acima me fornece no meu computador.

Arquivos de saída