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 tudo sobre planilhas do Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Saberexcel



 Baixe o Exemplo de planilha contendo a macro acima
vba copia dados novos workbook salva diretorio (23.29 kB 2010-11-20 18:21:48)