Adicionado em: | 20/11/2010 |
Modificado em: | 20/11/2010 |
Tamanho: | Vazio |
Downloads: | 606 |
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
Adicionado em: | 20/11/2010 |
Modificado em: | 20/11/2010 |
Tamanho: | Vazio |
Downloads: | 649 |
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
Adicionado em: | 20/11/2010 |
Modificado em: | 20/11/2010 |
Tamanho: | Vazio |
Downloads: | 896 |
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
Adicionado em: | 20/11/2010 |
Modificado em: | 20/11/2010 |
Tamanho: | Vazio |
Downloads: | 898 |
Essa macro do Aplicativo Microsoft Excel VBA, copia os dados da coluna(A) para a Coluna(C), observe que macro copia os dados o números de vezes que foi atribuido na célula representando a quantidade
Sub copia_para_coluna_C()
Dim vLinha As Integer
Dim vQtd As Integer
Dim vProduto As String
Dim vColunaPosicao As Integer
Dim j As Integer
Dim vInicio As Integer
Dim vFinal As Integer
'Pesquisa de valores em coluna B que começa em linha 2
vLinha = 2
'copia valores para coluna C começando na linha 2
vColunaPosicao = 2
'Pesquise em valores na coluna B até que uma célula em branco seja encontrada
While Len(Range("B" & CStr(vLinha)).Value) > 0
'Recupere o nome de produto e a quantidade
vQtd = Range("A" & CStr(vLinha)).Value
vProduto = Range("B" & CStr(vLinha)).Value
' posicionando o fim para cópia a coluna C
vInicio = vColunaPosicao
vFinal = vColunaPosicao + vQtd
'O copia o número de dados que é dado que é representado pela quantidade
For j = vInicio To vFinal - 1
Range("C" & CStr(j)).Value = vProduto
Next
'atualiza a posição na coluna C
vColunaPosicao = vFinal
vLinha = vLinha + 1
Wend
MsgBox "Copiou os dados para a coluna C.", vbInformation, "www.saberexcel.com"
End Sub
Sub limpar()
Range("C2:C1000").ClearContents
End Sub
Aprenda Aplicativo Microsoft Excel VBA - Saberexcel
Adicionado em: | 14/04/2013 |
Modificado em: | 14/04/2013 |
Tamanho: | Vazio |
Downloads: | 915 |
Esccola Saberexcel VBA Estudos® - Treinamentos com Macros, Fórmulas e Funções
Esse macro do aplicativo MS Excel VBA(Visual Basic Application), cria folha de planilhas planiihas com nome e dados dos alunos, com auxlio do Evento
Duplo Click, ou seja Cria uma planilha com dados do aluno nome do Aluno, com base no exemplo já existe.
as cores das abas de planihas criadas são geradas aleatóriamente (56) cores.
'a planilha modelo {Ficha_Aluno} ficará oculta.
Private Sub Worksheet_Activate()
fl_Aluno.Visible = False
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Application.Intersect(Range("A2:A1000"), Target) Is Nothing Then Exit Sub
vNome = ActiveCell
If vNome = "" Then Exit Sub
vIDADE = ActiveCell.Offset(0, 1)
vENDERECO = ActiveCell.Offset(0, 2)
vLICAO = ActiveCell.Offset(0, 3)
vNOTAS = ActiveCell.Offset(0, 4)
'para adicionar em outros campos
'vNome1= activecell.offset(0,5)
'vNome2= activecell.offset(0,6)
'testar se a planilha Ficha_Alunos (duplicação da planilha Ficha_Aluno - com o nome do Aluno)
For Each sh In Worksheets
If sh.Name = vNome Then MsgBox " Ficha_Aluno " & vNome & " planilha já foi criada!", vbCritical, "ERRO": Exit Sub
Next
Sheets("Ficha_Aluno").Visible = True
Sheets("Ficha_Aluno").Copy After:=Sheets(Worksheets.Count)
Sheets("Ficha_Aluno (2)").Select
Sheets("Ficha_Aluno (2)").Name = vNome
Sheets("Ficha_Aluno (2)").Tab.ColorIndex = Int(55 * Rnd) + 1
Sheets(vNome).Tab.ColorIndex = Int(55 * Rnd) + 1
Sheets("Ficha_Aluno").Select
ActiveWindow.SelectedSheets.Visible = False
Sheets(vNome).Select
Sheets(vNome).Range("B2") = vNome
Sheets(vNome).Range("B4") = vIDADE
Sheets(vNome).Range("B6") = vENDERECO
Sheets(vNome).Range("B8") = vLICAO
Sheets(vNome).Range("B10") = vNOTAS
Sheets(vNome).Range("A1").Select
End Sub
Sub deletar_planilhas()
Dim i As Long
On Error Resume Next
Application.DisplayAlerts = False
For i = 1 To Sheets.Count
If Len(Sheets(i).Name) = 1 And Sheets(i).Visible = True Then
Sheets(i).Delete
End If
Next i
End Sub
Aprenda tudo sobre planilhas do Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Escola Saberexcel VBA Estudos® - Treinamentos com Macros, Fórmulas e Funções.
Adquira já o Acesso Imediato
à Area de Membros
Aprenda Excel VBA com Simplicidade de
códigos e Eficácia, Escrevendo Menos e
Fazendo Mais.
'-------------------------------------'
Entrega Imediata:
+ 500 Video Aulas MS Excel VBA
+ 35.000 Planilhas Excel e VBA
+ Coleção 25.000 Macros MS Excel VBA
+ 141 Planilhas Instruções Loops
+ 341 Planilhas WorksheetFunctions(VBA)
+ 04 Módulos Como Fazer Excel VBA
+ Curso Completo MS Excel VBA
+ Planilhas Inteligentes
<script type="text/javascript"><!--
google_ad_client = "ca-pub-2317234650173689";
/* retangulo 336 x 280 */
google_ad_slot = "0315083363";
google_ad_width = 336;
google_ad_height = 280;
//-->
</script>
<script type="text/javascript"
src="http://pagead2.googlesyndication.com/pagead/show_ads.js">
</script>
Aprenda tudo sobre o Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Saberexcel,
Sobre as WorksheetFunctions Funções de Planilhas que retornam valores do VBA