Saberexcel - site das macros
Essas macros do Aplicativo Microsoft Excel VBA, copiam dados de uma determinada coluna para outra, para células pre-determinadas.
Observem que um assunto também muito importante é aprender a depurar uma macro, vejam a diferença em um código gravado e um código devidamente depurado para tal finalidade. Em outro tutorial pretendo apresentar uma matéria de como inserir um subtotal em grupo de números em uma lista de grupo de numero muito intensa.
Baixe o exemplo de planilha no final da página. Fiquem com Deus, Boa Sorte.
E_Marcondes.

'linha de código depurada
Sub depurando_codigo_gravado()
Plan2.[K1:K23000].Copy Plan1.[C1]
End Sub

'aqui a mesma macro que foi gravada, com algumas linhas de códigos que poderiam muito bem
'serem suprimidas, chamamos isso de depuração de código.
Sub macro_gravada()
Sheets("Plan2").Select
Range("K1:K23000").Select
Selection.Copy
Sheets("Plan1").Select
Range("C1").Select
ActiveSheet.Paste
Range("E1").Select
End Sub

Sub deletar_teste()
[C1:C23000].ClearContents
End Sub


Aprenda tudo sobre o Aplicativo Microsoft Excel VBA

Saberexcel - o site das macros
Esses procedimentos do Aplicativo Microsoft Excel VBA, copia os dados da linha selecionada para a coluna(A1), selecionado o e listando os dados desejados. Isso com auxlio de uma entrada de dados (Inputbox)
Observe que usei a propriedade OffSet para deslocar uma linha abaixo para colar os dados.
É muito importante aprender sobre esta propriedade para um bom aprendizado em VBA, temos excelentes exemplos nos módulos COMO FAZER - Programação MS Excel VBA - Saberexcel.

Private Sub Worksheet_Activate()
Application.EditDirectlyInCell = False
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Dim vCelula As Long
Dim vEndereco As String

vCelula = ActiveCell.Row
vEndereco = Cells(vCelula, 3)
vEndereco = vEndereco & ", " & Cells(vCelula, 4)
vEndereco = vEndereco & ", " & Cells(vCelula, 5)
vEndereco = vEndereco & ", " & Cells(vCelula, 6)
vEndereco = vEndereco & ", " & Cells(vCelula, 7)

vEndereco = InputBox("Selecione a linha desejada!", Cells(vCelula, 4) & " - " & Cells(vCelula, 5) & "- [ Saberexcel ] ", vEndereco)
[A65000].End(xlUp).Offset(1, 0).Select 'deslocando para primeira célula em branco
ActiveCell.Value = vEndereco

End Sub



Aprenda tudo sobre o aplicativo Microsoft Excel VBA com Saberexcel

Essa macro do Aplicativo Microsoft Excel VBA, contém uma macro que copia dados referente a um determinado intervalo de datas e cola em outra folha de planilha também no mesmo intervalo de datas.


Sub Copiar_dados_para_outra_plan()

Dim vData As String
Dim vColuna As Integer
Dim vEncontrar As Boolean

On Error GoTo Err_Execute

'Retorna o valor da data
vData = Sheets("Planilha Dados").Range("B4").Value

Sheets("Plan").Select

'inicia na coluna(B)
vColuna = 2
vEncontrar = False

While vEncontrar = False

'se encontrar uma célula em branco na linha 2, termina a busca
If Len(Cells(2, vColuna)) = 0 Then
MsgBox "Dados não encontrados.", vbInformation, "http://www.saberexcel.com"
Exit Sub

'dados encontrado após a linha 2
ElseIf Cells(2, vColuna) = vData Then

'Seleciona valor para copiar da "Planilha Dados"
Sheets("Planilha Dados").Select
Range("B5:H6").Select
Selection.Copy

'Cola na "Plan"
Sheets("Plan").Select
Cells(3, vColuna).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

vEncontrar = True
MsgBox "Os dados foram copiados com sucesso!!", vbInformation, "http://www.saberexcel.com"

'continua a procura
Else
vColuna = vColuna + 1
End If

Wend

On Error GoTo 0

Exit Sub

Err_Execute:
MsgBox "Ocorreu um #erro#!", vbInformation, "http://www.saberexcel.com"

End Sub

Aprenda Aplicativo Microsoft Excel VBA - SaberExcel

SaberExcel - o Site das Macros
Essa macro do Aplicativo Microsoft Excel VBA, copia dados desejados de uma planilha principal para outras planilhas indicadas, observe que a macro faz a referencia para exportação de dados na coluna(A), com o prefixo do nome da Planilha, por exemplo PRODUTORES LISTA, ("P"), SB PECAS("S"), TB CODIGO("T")

Sub Copiando_dados_distribuindo_plans_desejadas()

Dim vPlanPrincipal, vPlanilhaP, vPlanilhaS, vPlanilhaT As String
Dim vContinuar As Boolean
Dim vPrimeiraLinha, vLinha As Integer
Dim vAtualPLinha, vAtualSLinha, vAtualTLinha As Integer

'nome referenciando as folhas de planilha
vPlanPrincipal = "BOM"
vPlanilhaP = PRODUTORES LISTA"
vPlanilhaS = "PARTES PECAS"
vPlanilhaT = "CODIGOS"

'Inicializando com as variáveis
vContinuar = True
vPrimeiraLinha = 13
vLinha = vPrimeiraLinha
vAtualPLinha = 12
vAtualSLinha = 12
vAtualTLinha = 12

Sheets(vPlanPrincipal).Select

'Um loop por todos os valores da coluna(A) até encontrar uma célula em branco
While vContinuar = True

'Quando encontrar uma célula em branco, não continua
If Len(Range("A" & CStr(vLinha)).Value) = 0 Then
vContinuar = False
'copiando e formatando dados
Else

'inserindo uma borda arredondada nas células
Range("A" & CStr(vLinha) & ":I" & CStr(vLinha)).Borders(xlEdgeLeft).LineStyle = xlContinuous
Range("A" & CStr(vLinha) & ":I" & CStr(vLinha)).Borders(xlEdgeLeft).Weight = xlThin
Range("A" & CStr(vLinha) & ":I" & CStr(vLinha)).Borders(xlEdgeTop).LineStyle = xlContinuous
Range("A" & CStr(vLinha) & ":I" & CStr(vLinha)).Borders(xlEdgeTop).Weight = xlThin
Range("A" & CStr(vLinha) & ":I" & CStr(vLinha)).Borders(xlEdgeBottom).LineStyle = xlContinuous
Range("A" & CStr(vLinha) & ":I" & CStr(vLinha)).Borders(xlEdgeBottom).Weight = xlThin
Range("A" & CStr(vLinha) & ":I" & CStr(vLinha)).Borders(xlEdgeRight).LineStyle = xlContinuous
Range("A" & CStr(vLinha) & ":I" & CStr(vLinha)).Borders(xlEdgeRight).Weight = xlThin
Range("A" & CStr(vLinha) & ":I" & CStr(vLinha)).Borders(xlInsideVertical).LineStyle = xlContinuous
Range("A" & CStr(vLinha) & ":I" & CStr(vLinha)).Borders(xlInsideVertical).Weight = xlThin

'referenciando às células da coluna(I)
Range("I" & CStr(vLinha)).Formula = "=H" & CStr(vLinha) & "*QTY"

'--- "A" ---
If Range("A" & CStr(vLinha)).Value = "A" Then

'Negrito e justificando à esquerda
Range(CStr(vLinha) & ":" & CStr(vLinha)).Font.Bold = True
Range(CStr(vLinha) & ":" & CStr(vLinha)).HorizontalAlignment = xlLeft

'se nao encontrar a primeira linha, insere uma linha em branco
If vLinha <> vPrimeiraLinha Then
Rows(CStr(vLinha) & ":" & CStr(vLinha)).Select
Selection.Insert Shift:=xlDown
vLinha = vLinha + 1
End If

'--- "P" ---
ElseIf Range("A" & CStr(vLinha)).Value = "P" Then

'Cópia dados avaliando das colunas B, C, F, G, para folha BMO
Range("B" & CStr(vLinha) & ",C" & CStr(vLinha) & ",F" & CStr(vLinha) & ",G" & CStr(vLinha) & ",I" & CStr(vLinha)).Select
Selection.Copy

'Para folha "LISTA COMPRADORES"
Sheets(vPlanilhaP).Select
Range("A" & CStr(vAtualPLinha)).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A1").Select

'adicionando bordas arredondadas nas células
Range("A" & CStr(vAtualPLinha) & ":E" & CStr(vAtualPLinha)).Borders(xlEdgeLeft).LineStyle = xlContinuous
Range("A" & CStr(vAtualPLinha) & ":E" & CStr(vAtualPLinha)).Borders(xlEdgeLeft).Weight = xlThin
Range("A" & CStr(vAtualPLinha) & ":E" & CStr(vAtualPLinha)).Borders(xlEdgeTop).LineStyle = xlContinuous
Range("A" & CStr(vAtualPLinha) & ":E" & CStr(vAtualPLinha)).Borders(xlEdgeTop).Weight = xlThin
Range("A" & CStr(vAtualPLinha) & ":E" & CStr(vAtualPLinha)).Borders(xlEdgeBottom).LineStyle = xlContinuous
Range("A" & CStr(vAtualPLinha) & ":E" & CStr(vAtualPLinha)).Borders(xlEdgeBottom).Weight = xlThin
Range("A" & CStr(vAtualPLinha) & ":E" & CStr(vAtualPLinha)).Borders(xlEdgeRight).LineStyle = xlContinuous
Range("A" & CStr(vAtualPLinha) & ":E" & CStr(vAtualPLinha)).Borders(xlEdgeRight).Weight = xlThin
Range("A" & CStr(vAtualPLinha) & ":E" & CStr(vAtualPLinha)).Borders(xlInsideVertical).LineStyle = xlContinuous
Range("A" & CStr(vAtualPLinha) & ":E" & CStr(vAtualPLinha)).Borders(xlInsideVertical).Weight = xlThin

'incrementando linha contador na planilha "LISTA COMPRADORES"
vAtualPLinha = vAtualPLinha + 1

'Retornando a planilha BOM no local de origem
Sheets(vPlanPrincipal).Select

'--- "S" ---
ElseIf Range("A" & CStr(vLinha)).Value = "S" Then

'copia avaliando as colunas B, C, e E da folha BMO
Range("B" & CStr(vLinha) & ",C" & CStr(vLinha) & ",E" & CStr(vLinha)).Select
Selection.Copy

'Cola os dados na planilha "PARTES PECAS"
Sheets(vPlanilhaS).Select
Range("A" & CStr(vAtualSLinha)).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

'copie valores das colunas D, F, G, e da folha BMO
Sheets(vPlanPrincipal).Select
Range("D" & CStr(vLinha) & ",F" & CStr(vLinha) & ",G" & CStr(vLinha) & ",I" & CStr(vLinha)).Select
Selection.Copy

'cola dados na planilha "PARTES PECAS"
Sheets(vPlanilhaS).Select
Range("D" & CStr(vAtualSLinha)).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A1").Select

'Insere bordas arredondadas nas células
Range("A" & CStr(vAtualSLinha) & ":G" & CStr(vAtualSLinha)).Borders(xlEdgeLeft).LineStyle = xlContinuous
Range("A" & CStr(vAtualSLinha) & ":G" & CStr(vAtualSLinha)).Borders(xlEdgeLeft).Weight = xlThin
Range("A" & CStr(vAtualSLinha) & ":G" & CStr(vAtualSLinha)).Borders(xlEdgeTop).LineStyle = xlContinuous
Range("A" & CStr(vAtualSLinha) & ":G" & CStr(vAtualSLinha)).Borders(xlEdgeTop).Weight = xlThin
Range("A" & CStr(vAtualSLinha) & ":G" & CStr(vAtualSLinha)).Borders(xlEdgeBottom).LineStyle = xlContinuous
Range("A" & CStr(vAtualSLinha) & ":G" & CStr(vAtualSLinha)).Borders(xlEdgeBottom).Weight = xlThin
Range("A" & CStr(vAtualSLinha) & ":G" & CStr(vAtualSLinha)).Borders(xlEdgeRight).LineStyle = xlContinuous
Range("A" & CStr(vAtualSLinha) & ":G" & CStr(vAtualSLinha)).Borders(xlEdgeRight).Weight = xlThin
Range("A" & CStr(vAtualSLinha) & ":G" & CStr(vAtualSLinha)).Borders(xlInsideVertical).LineStyle = xlContinuous
Range("A" & CStr(vAtualSLinha) & ":G" & CStr(vAtualSLinha)).Borders(xlInsideVertical).Weight = xlThin

'incrementa o contador de linhas na planilha "PARTES PECAS"
vAtualSLinha = vAtualSLinha + 1

'Retorna para planilha BMO e continua onde parou
Sheets(vPlanPrincipal).Select

'--- "T" ---
ElseIf Range("A" & CStr(vLinha)).Value = "T" Then

'copia valores da coluna B para planilha BMO
Range("B" & CStr(vLinha)).Select
Selection.Copy

'Cola os dados na planilha "CODIGOS"
Sheets(vPlanilhaT).Select
Range("A" & CStr(vAtualTLinha)).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

'insere vírgula nos lugares na coluna(B)
Range("B" & CStr(vAtualTLinha)).Value = ","

'Copia os valores de coluna(I) da planilha BMO)
Sheets(vPlanPrincipal).Select
Range("I" & CStr(vLinha)).Select
Selection.Copy

'Cola os valores na planilha "CODIGOS"
Sheets(vPlanilhaT).Select
Range("C" & CStr(vAtualTLinha)).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A1").Select

'insere bordas arredondadas nas células
Range("A" & CStr(vAtualTLinha) & ":C" & CStr(vAtualTLinha)).Borders(xlEdgeLeft).LineStyle = xlContinuous
Range("A" & CStr(vAtualTLinha) & ":C" & CStr(vAtualTLinha)).Borders(xlEdgeLeft).Weight = xlThin
Range("A" & CStr(vAtualTLinha) & ":C" & CStr(vAtualTLinha)).Borders(xlEdgeTop).LineStyle = xlContinuous
Range("A" & CStr(vAtualTLinha) & ":C" & CStr(vAtualTLinha)).Borders(xlEdgeTop).Weight = xlThin
Range("A" & CStr(vAtualTLinha) & ":C" & CStr(vAtualTLinha)).Borders(xlEdgeBottom).LineStyle = xlContinuous
Range("A" & CStr(vAtualTLinha) & ":C" & CStr(vAtualTLinha)).Borders(xlEdgeBottom).Weight = xlThin
Range("A" & CStr(vAtualTLinha) & ":C" & CStr(vAtualTLinha)).Borders(xlEdgeRight).LineStyle = xlContinuous
Range("A" & CStr(vAtualTLinha) & ":C" & CStr(vAtualTLinha)).Borders(xlEdgeRight).Weight = xlThin
Range("A" & CStr(vAtualTLinha) & ":C" & CStr(vAtualTLinha)).Borders(xlInsideVertical).LineStyle = xlContinuous
Range("A" & CStr(vAtualTLinha) & ":C" & CStr(vAtualTLinha)).Borders(xlInsideVertical).Weight = xlThin

'incrementa o contador da planilha "CODIGOS"
vAtualTLinha = vAtualTLinha + 1

'Retorna para a planilha BMO
Sheets(vPlanPrincipal).Select

End If

End If

vLinha = vLinha + 1

Wend

MsgBox "Os dados foram copiados com sucesso!!", vbInformation, "Saberexcel - site das macros"

End Sub

Aprenda Aplicativo Microsoft Excel VBA --(( Saberexcel ))--

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