Neste artigo, criaremos uma macro para copiar dados de várias pastas de trabalho em uma pasta para uma nova pasta de trabalho.
Vamos criar duas macros; uma macro copiará apenas os registros da primeira coluna para a nova pasta de trabalho e a segunda macro copiará todos os dados nela.
Os dados brutos para este exemplo consistem em registros de presença de funcionários. No TestFolder, temos vários arquivos Excel. Os nomes dos arquivos do Excel representam uma data específica no formato “ddmmaaaa”.
Cada arquivo do Excel contém a data, a identificação do funcionário e o nome do funcionário que estiveram presentes naquele dia específico.
Criamos duas macros; “CopyingSingleColumnData” e “CopyingMultipleColumnData”. A macro “CopyingSingleColumnData” copiará apenas os registros da primeira coluna de todos os arquivos na pasta para a nova pasta de trabalho. A macro “CopyingMultipleColumnData” copiará todos os dados de todos os arquivos da pasta para a nova pasta de trabalho.
A macro “CopyingSingleColumnData” pode ser executada clicando no botão “Copying Single Column”. A macro “CopyingMultipleColumnData” pode ser executada clicando no botão “Copiando colunas múltiplas”.
Antes de executar a macro, deve-se especificar o caminho da pasta na caixa de texto, onde os arquivos Excel são colocados.
Ao clicar no botão “Copiando Coluna Única”, uma nova pasta de trabalho “ConsolidatedFile” será gerada na pasta definida, que conterá os dados consolidados da primeira coluna de todos os arquivos da pasta.
A nova pasta de trabalho conterá apenas registros na primeira coluna. Assim que tivermos os dados consolidados, podemos descobrir o número de funcionários presentes em um determinado dia contando o número da data. A contagem de uma data específica será igual ao número de funcionários presentes naquele dia específico.
Ao clicar no botão “Copiando várias colunas”, será gerada a nova pasta de trabalho “ConsolidatedAllColumns” na pasta definida, que conterá dados consolidados de todos os registros de todos os arquivos da pasta.
A nova pasta de trabalho criada conterá todos os registros de todos os arquivos da pasta. Assim que tivermos os dados consolidados, teremos todos os dados do atendimento disponíveis em um único arquivo. Podemos localizar facilmente o número de funcionários presentes naquele dia específico e também obter os nomes dos funcionários que estavam presentes naquele dia específico.
Explicação do código
Sheet1.TextBox1.Value
O código acima é usado para obter o valor inserido na caixa de texto “TextBox1” da planilha “Plan1”.
Dir (FolderPath & "* .xlsx")
O código acima é usado para obter o nome do arquivo, que possui a extensão “.xlsx”. Usamos curinga * para nomes de arquivo de vários caracteres.
Enquanto FileName ""
Contagem1 = Contagem1 + 1
ReDim Preserve FileArray (1 para Count1)
FileArray (Count1) = FileName
Nome do arquivo = Dir ()
Wend
O código acima é usado para obter os nomes de todos os arquivos da pasta.
Para i = 1 para UBound (FileArray)
Próximo
O código acima é usado para percorrer todos os arquivos da pasta.
Range ("A1", Cells (LastRow, 1)). Copiar DestWB.ActiveSheet.Cells (LastDesRow, 1)
O código acima é usado para copiar o registro da primeira coluna para a pasta de trabalho de destino.
Range ("A1", ActiveCell.SpecialCells (xlCellTypeLastCell)). Copiar DestWB.ActiveSheet.Cells (LastDesRow, 1)
O código acima é usado para copiar todos os registros da pasta de trabalho ativa para a pasta de trabalho de destino.
Siga abaixo para o código
Option Explicit Sub CopyingSingleColumnData () 'Declarando variáveis Dim FileName, FolderPath, FileArray (), FileName1 As String Dim LastRow, LastDesRow, Count1, i As Integer Dim SourceWB, DestWB As Workbook Application.ScreenUpdating = False FolderPath = Sheet1.TextBox1.Value' Inserindo barra invertida no caminho da pasta se a barra invertida (\) estiver ausente If Right (FolderPath, 1) "\" Then FolderPath = FolderPath & "\" End If 'Pesquisando arquivos Excel FileName = Dir (FolderPath & "* .xlsx") Count1 = 0 'Looping por todos os arquivos Excel na pasta While FileName "" Count1 = Count1 + 1 ReDim Preserve FileArray (1 para Count1) FileArray (Count1) = FileName FileName = Dir () Wend' Criando uma nova pasta de trabalho Definir DestWB = Workbooks.Add For i = 1 To UBound (FileArray) 'Localizando a última linha na pasta de trabalho LastDesRow = DestWB.ActiveSheet.Range ("A1"). SpecialCells (xlCellTypeLastCell) .Row' Abrindo a pasta de trabalho do Excel Definir SourceWB = Workbooks.Open (FolderPath & FileArray (i)) LastRow = ActiveCell.SpecialCells (xlCellTypeLas tCell) .Row 'Colando os dados copiados para a última linha na pasta de trabalho de destino If LastDesRow = 1 Then' Copiando a primeira coluna para a última linha na pasta de destino Range ("A1", Cells (LastRow, 1)). Copiar DestWB. ActiveSheet.Cells (LastDesRow, 1) Else Range ("A1", Cells (LastRow, 1)). Copiar DestWB.ActiveSheet.Cells (LastDesRow + 1, 1) End If SourceWB.Close False Next 'Salvando e fechando um novo Excel pasta de trabalho DestWB.SaveAs FileName: = FolderPath & "ConsolidatedFile.xlsx" DestWB.Close Set DestWB = Nothing Set SourceWB = Nothing End Sub Sub CopyingMultipleColumnData () 'Declarando variáveis Dim FileName, FolderPath, FileArray (), FileName1 As String Dim LastRow, LastDesRow , Count1, i As Integer Dim SourceWB, DestWB As Workbook Application.ScreenUpdating = False FolderPath = Sheet1.TextBox1.Value 'Inserindo barra invertida no caminho da pasta se a barra invertida (\) estiver ausente If Right (FolderPath, 1) "\" Then FolderPath = FolderPath & "\" End If 'Pesquisando arquivos do Excel FileName = Dir (FolderPath & "* .xlsx") Count1 = 0 'Looping por todos os arquivos Excel na pasta While FileName "" Count1 = Count1 + 1 ReDim Preserve FileArray (1 To Count1) FileArray (Count1) = FileName FileName = Dir () Wend' Criando uma nova pasta de trabalho Definir DestWB = Workbooks.Add For i = 1 To UBound (FileArray) 'Localizando a última linha na pasta de trabalho LastDesRow = DestWB.ActiveSheet.Range ("A1"). SpecialCells (xlCellTypeLastCell) .Row' Abrindo a pasta de trabalho Excel Defina SourceWB = Workbooks.Open (FolderPath & FileArray (i)) 'Colando os dados copiados na última linha na pasta de trabalho de destino If LastDesRow = 1 Then' Copiando todos os dados na planilha para a última linha na pasta de trabalho de destino Range ("A1", ActiveCell.SpecialCells (xlCellTypeLastCell)). Copiar DestWB.ActiveSheet.Cells (LastDesRow, 1) Else Range ("A1", ActiveCell.SpecialCells (xlCellTypeLastCell)). Copiar DestWB.ActiveSheet.Cells (LastDesRow + 1, 1) End If SourceWB.Close False Next 'Salvando e fechando uma nova pasta de trabalho do Excel DestWB.SaveAs FileName: = FolderPath & "ConsolidatedAllColumns.xlsx" DestWB.Close Set D estWB = Nothing Set SourceWB = Nothing End Sub
Se você gostou deste blog, compartilhe com seus amigos no Facebook. Além disso, você pode nos seguir no Twitter e no Facebook.
Gostaríamos muito de ouvir de você, diga-nos como podemos melhorar nosso trabalho e torná-lo melhor para você. Escreva para nós no site de e-mail