|
 Saberexcel - o Site das Macros
Essa macro do Aplicativo Microsoft Excel VBA, contém macro que copia determinados dados de uma planilha e salva novos Workbook com nome dos dados existentes na coluna(A), foi escolhido o Diretório C:\VBA\ , mas você poderá indicar um novo caminho para seu computador, para entender melhor baixe a planilha exemplo.
Sub Copiar_dados_novos_wkb_salvar()
Dim wbkPrincipal As String
Dim vNovoWkb As String
Dim vLinha As Integer
Dim vContinuar As Boolean
Dim vColAMestre As String
Dim vColATeste As String
Dim WkbContador As Integer
Dim vMensagem As String
Dim vDiretorio As String
Dim vArquivoNome As String
Dim vColAValor As String
'Diretorio onde salvará os novos Workbooks
vDiretorio = "C:\VBA\"
'Retorna o nome do workbook contendo os dados a serem copiados
wbkPrincipal = ActiveWorkbook.Name
'Inicilizando com variáveis
vContinuar = True
vLinha = 2
WkbContador = 0
'Inicio da comparação com a célula(A2)
vColAMestre = "A2"
'Loop em todos os ítemns coluna (A) até encontrar encontrar uma célula em branco
While vContinuar = True
vLinha = vLinha + 1
vColATeste = "A" & CStr(vLinha)
'Quando encontrar um célula em branco, sai do loop
If Len(Range(vColATeste).Value) = 0 Then
vContinuar = False
End If
'Valor que esta na coluna(A)
vColAValor = Range(vColAMestre).Value
'A ocorrência encontrada que que não combina, é copiada para o novo livro de exercícios
If vColAValor <> Range(vColATeste).Value Then
'Copiando o cabeçalho
Range("A1:D1").Select
Selection.Copy
'Adicionando novo Workbook e colando o cabeçalho no novo Wkb Livro
Workbooks.Add
vNovoWkb = ActiveWorkbook.Name
ActiveSheet.Paste
Range("A1").Select
'Copiando os dados da coluna A - D
Windows(wbkPrincipal).Activate
Range(vColAMestre & ":D" & CStr(vLinha - 1)).Select
Selection.Copy
'Colando os resultados
Windows(vNovoWkb).Activate
Range("A2").Select
ActiveSheet.Paste
Range("A1").Select
On Error Resume Next 'tratando um possível erro
'Salvando os Workboks se necessário com o nome das frases da coluna A
'e logo fechando o livro de exercícios
vArquivoNome = vDiretorio & vColAValor & ".xls"
If Dir(vArquivoNome) <> "" Then Kill vArquivoNome
ActiveWorkbook.SaveAs Filename:=vArquivoNome
ActiveWorkbook.Close
'Voltando para a planilha principal ao ponto desejado
Windows(wbkPrincipal).Activate
vColAMestre = "A" & CStr(vLinha)
'variável contador emite na msgbox quantas planilhas foram salvas
WkbContador = WkbContador + 1
End If
Wend
Range("A1").Select
Application.CutCopyMode = False
vMensagem = "Dados copiados com sucesso! copiados para [ " & WkbContador & " ] novos Workbook."
vMensagem = vMensagem & Chr(10) & "Salvo no Diretório : [ " & Chr(10) & vDiretorio & " ]"
MsgBox vMensagem, vbInformation, "Saberexcel - o Site das Macros"
End Sub
Aprenda Aplicativo Microsoft Excel VBA com SaberExcel
 |