Divide a planilha do Excel em várias planilhas com base em uma coluna com o VBA

Question

A pergunta é simples e pode ser repetitiva.

1. Eu tenho uma pasta de trabalho do Excel que contém cerca de 50 colunas
2. Eu tenho uma coluna de critérios para dividir esta pasta de trabalho em várias pastas de trabalho

A abordagem é mostrada abaixo

Name    SportGoods    quantity
ABC     CRICKETBAT    10
DEF     BaseballBat   20
GHI     football      30 
MNO     gloves        10
PQR     shoes         10 
ABCD    CRICKET SHOES 10
DEFG    BaseballBat   20
GHIL    football      30 
MNOP    gloves        10
PQRS    shoes         10 

Estou procurando uma macro que me permita criar várias pastas de trabalho do Excel com base na coluna SportGoods , como:

• Excel / CSV para todos os itens de críquete, como CRICKETBAT, SAPATOS DE CRICKET, luvas
• Excel / CSV para todos os itens de futebol, como futebol e calçados

Como parâmetro de entrada, eu estaria fornecendo itens de críquete distintos, itens de futebol distintos. A fonte seria uma grande planilha de dados do Excel que contém ~ 5000 registros.

Alguém pode me ajudar com uma macro que ajudaria na geração de várias pastas de trabalho com base nos detalhes acima?

    

Answer 1

Resumo

Esta é uma macro curta, mas inteligente. Divide & salva os dados na planilha ativa em diferentes arquivos CSV. Os arquivos recém-criados são armazenados em uma nova pasta chamada saída CSV no mesmo local do arquivo do Excel.

Macro VBA

Sub GenerateCSV()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

iCol = 2                                '### Define your criteria column
strOutputFolder = "CSV output"          '### Define your path of output folder

Set ws = ThisWorkbook.ActiveSheet       '### Don't edit below this line
Set rngLast = Columns(iCol).Find("*", Cells(1, iCol), , , xlByColumns, xlPrevious)
ws.Columns(iCol).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUnique = Range(Cells(2, iCol), rngLast).SpecialCells(xlCellTypeVisible)

If Dir(strOutputFolder, vbDirectory) = vbNullString Then MkDir strOutputFolder
For Each strItem In rngUnique
  If strItem <> "" Then
    ws.UsedRange.AutoFilter Field:=iCol, Criteria1:=strItem.Value
    Workbooks.Add
    ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=[A1]
    strFilename = strOutputFolder & "\" & strItem
    ActiveWorkbook.SaveAs Filename:=strFilename, FileFormat:=xlCSV
    ActiveWorkbook.Close savechanges:=False
  End If
Next
ws.ShowAllData

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

^{Salve-o em um novo módulo VBA}

Entendendo o código

iCol = 2                               
strOutputFolder = "CSV output"        

A primeira linha é sua coluna de critérios. Um 1 representaria a coluna A, 2 da coluna B e assim por diante.
Segundo, definimos um nome de pasta onde todos os nossos arquivos CSV devem ser salvos. Você também pode definir um caminho completo como C:\some\folder . Caso contrário, o Excel criará uma pasta na localização do seu arquivo do Excel

 Set ws = ThisWorkbook.ActiveSheet      

Aqui, salvamos nossa pasta de trabalho e planilha atuais em uma variável. Não é necessário fazer isso, mas como estamos lidando com várias pastas de trabalho (recém-criadas) eu recomendo isso

Set rngLast = Columns(iCol).Find("*", Cells(1, iCol), , , xlByColumns, xlPrevious)
ws.Columns(iCol).AdvancedFilter Action:=xlFilterInPlace, Unique:=True   
Set rngUnique = Range(Cells(2, iCol), rngLast).SpecialCells(xlCellTypeVisible)

Ok, o que isso faz? Primeiro, pesquisamos a última célula apenas na coluna de critérios. Isso deve ser feito antes de nossa filtragem e é necessário mais tarde. Em seguida, usamos o famoso método filtro avançado para filtrar todos os valores duplicados de nossa coluna de critérios. Por fim, salvamos todas as células visíveis em uma variável chamada rngUnique

If Dir(strOutputFolder, vbDirectory) = vbNullString Then MkDir strOutputFolder

Vamos ver se uma pasta chamada CSV output já existe. Se não, crie um

For Each strItem In rngUnique
  If strItem <> "" Then
  [...]
  End If
Next

Agora, começamos a percorrer todos os valores exclusivos em nossa variável rngUnique . Mas os valores vazios são ignorados

ws.UsedRange.AutoFilter Field:=iCol, Criteria1:=strItem.Value

Uma linha importante. Usamos o método de autofiltro e visualizamos todas as linhas que correspondem ao nosso valor único atual. O antigo filtro avançado é cancelado automaticamente.

Workbooks.Add
ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=[A1]

Essas duas linhas criam uma nova pasta de trabalho vazia e copiam apenas as células visíveis da nossa pasta de trabalho de entrada

strFilename = strOutputFolder & "\" & strItem

Aqui nós montamos o caminho CSV. Nós tomamos o valor único atual como nome de arquivo. A extensão CSV é anexada automaticamente, pois escolhemos xlCSV como formato de saída.
Certifique-se de que seus valores exclusivos não contêm caracteres de nome de arquivo inválidos, como < > | / * \ ? " , ou o arquivo CSV correspondente não será criado

ActiveWorkbook.SaveAs Filename:=strFilename, FileFormat:=xlCSV
ActiveWorkbook.Close savechanges:=False

O último passo é salvar a pasta de trabalho atual como um CSV e usar a variável strFilename como nome do arquivo. O delimitador CSV depende do seu delimitador de configuração regional. É possível alterar o formato do arquivo , por exemplo. para pasta de trabalho CSV ou Excel 2003 delimitada por tabulações

Application.ScreenUpdating = False
Application.DisplayAlerts = False

A primeira linha acelera nossa macro um pouco, já que o Excel não precisa mostrar cada etapa da filtragem.
A segunda linha suprime os irritantes File already exists . Mais tarde, habilitamos essas funções novamente