none
Localizar e Copiar coluna inteira RRS feed

  • Pergunta

  • Srs. Boa Noite.

    Estou aprendendo a programar em VBA, e tenho uma dúvida. Como faço para buscar uma informação dentro de uma planilha, pelo cabeçário,  copiar a respectiva coluna (Pode ter células em brando) e colar em outro arquivo.

    Usei o seguinte código (Com ajuda do gravador de Macros):

     Windows("RELATÓRIO DE VANDALISMO.xls").Activate
        Cells.Find(What:="BDN", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False).Activate
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        Windows("Vandalismo.xlsx").Activate
        ActiveSheet.Paste

    Porém, se encontra alguma célula em branco no meio, não copia as demais.

    Desde já, muito obrigado.

    terça-feira, 17 de setembro de 2013 02:08

Respostas

  • Ao inserir um código no fórum, utilize blocos de código. Para utilizar essa ferramenta, clique no botão cuja legenda é “Inserir bloco de código” na barra do editor de mensagens do fórum.

    ---

    Sub fncMain()
        Dim lngCol As Long
        Dim lngLastRow As Long
        Dim wksOrigem As Worksheet
        
        'Mudar Plan1 para o nome correto da planilha
        Set wksOrigem = Workbooks("RELATÓRIO DE VANDALISMO.xls").Worksheets("Plan1")
            
        lngCol = fncMatch("BDN", wksOrigem.Rows(1))
        lngLastRow = fncGetLastRow(wksOrigem.Columns(lngCol))
        wksOrigem.Cells(2, lngCol).Resize(lngLastRow - 2 + 1).Copy Destination:=ActiveCell
    End Sub
    
    Function fncMatch(ByVal str As String, ByVal varVetor As Variant) As Long
        Dim Temp As Long
        
        On Error Resume Next
        Temp = WorksheetFunction.Match(str + 0, varVetor, 0)
        If Temp = 0 Then Temp = WorksheetFunction.Match(CStr(str), varVetor, 0)
        fncMatch = Temp
    End Function
    
    Function fncGetLastRow(rng As Range) As Long
        Dim Temp As Long
        
        With rng
            On Error Resume Next
            Temp = .Find(What:="*" _
            , After:=.Cells(1) _
            , SearchDirection:=xlPrevious _
            , SearchOrder:=xlByColumns _
            , LookIn:=xlFormulas).Row
            If Temp = 0 Then Temp = rng.Cells(1).Row
        End With
        fncGetLastRow = Temp
    End Function


    sábado, 21 de setembro de 2013 22:16
    Moderador