none
Localizar e copiar dados de abas RRS feed

  • Pergunta

  • Boa tarde,

    Tenho uma aba (plan1) que tem um layout a seguir, na outra aba(plan2) tenho os mesmos valores, porem com o layout diferente.

    Estou criando uma nova aba(plan3) que vira com os dados da plan2 mas com o layout da plan1.

    Os dados da plan2 estão desordenados e referenciados com X, quando eu localizar o valor X gostaria de copiar a celula que contem a descrição do valor X.

    Segue código:

    Private Sub CommandButton2_Click()
    Dim mySheet
    
        
            mySheet = CmbPlan.Value
            mySheet2 = CmbPlan2.Value
                    
            'Limpa os Combos
            CmbPlan.ListIndex = -1
            CmbPlan2.ListIndex = -1
            
            'Altere os Ranges a Copiar e Colar
            Worksheets(mySheet).Range("A1:D2").Copy _
            Destination:=Sheets(mySheet2).Range("A1")
            
                        
            Worksheets("Geral Mineroduto").Range("A3:A5000").Copy _
            Destination:=Sheets(mySheet2).Range("A3")
            
            Worksheets("Geral Mineroduto").Range("C3:C5000").Copy _
            Destination:=Sheets(mySheet2).Range("C3")
            
            Worksheets("Geral Mineroduto").Range("B3:B5000").Copy _
            Destination:=Sheets(mySheet2).Range("D3")
    
    
        Dim iLinha As Integer
        Dim iColuna As Integer
        Dim Qtde As Integer
        Dim ValorCel As Integer
        Dim EncontraString As String
        Dim Rng As Range
        
        
        Qtde = 240 ' define a quantidade de linhas a percorrer na planilha.
        QtdeCol = 4 ' define a quantidade de colunas a percorrer na planilha.
        
        For iLinha = 3 To Qtde ' iLinha igual a dois para desconsiderar os títulos das colunas caso exista.
            
            For iColuna = 2 To QtdeCol
                
                'Sheets(mySheet2).Cells(iLinha, iColuna).Value = "OK"
                Next iColuna
                Next iLinha
            
            
            EncontraString = "X"
            If Trim(EncontraString) <> "" Then
            With Sheets("Geral Mineroduto").Range("D3:K240")
                Set Rng = .Find(What:=EncontraString, _
                                After:=.Cells(.Cells.Count), _
                                LookIn:=xlValues, _
                                LookAt:=xlWhole, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlNext, _
                                MatchCase:=False)
                If Not Rng Is Nothing Then
                    Application.Goto Rng, True
                    Worksheets("Sheet1").Range("B3").Value = Rng
                End If
                
                
                
            End With
        
           
        
        End If
        
        
      
        
       End
        
        End Sub
        
    Private Sub UserForm_Initialize()
    Dim ws As Worksheet
    
        For Each ws In ThisWorkbook.Worksheets
                CmbPlan.AddItem (ws.Name)
                CmbPlan2.AddItem (ws.Name)
        Next ws
            
    End Sub
    
    e segue uma imagem 
    quinta-feira, 1 de agosto de 2013 17:31

Respostas

  • Consegui desta forma:

        Dim iLinha As Integer
        Dim iColuna As Integer
        Dim cont1 As Integer
        Dim cont2 As Integer
        Dim Qtde As Long
        Dim vlCelulaBusca As Long
        Dim vlColunaBusca As Long
        Dim rngMerged As Range
        Dim rng As Range
        Dim sÁrea As String
        Dim sFórmula As String
    
    Sub buscar()
                
        mySheet1 = "mysheet" 'Defina qual sera a ABA ORIGEM
        mySheet2 = "mysheet" 'Defina qual sera a ABA DESTINO
            
        Worksheets(mySheet1).Select
                   
        'Percorre todas as linhas até encontrar a ultima que possiu valor
        vlCelulaBusca = Cells.Find(What:="*", After:=Range("A1"), _
                   SearchOrder:=xlByRows, _
                   SearchDirection:=xlPrevious).Row
                   
        'Percorre todas as coluna até encontrar a ultima que possiu valor
        vlColunaBusca = ActiveSheet.Cells.Find(What:="*", _
                           SearchDirection:=xlPrevious, _
                           SearchOrder:=xlByColumns).Column
                           
        Qtde = vlCelulaBusca
        QtdeCol = vlColunaBusca
        
        'tirar celulas mescladas
        With ActiveSheet
            For Each rngMerged In .UsedRange
                If rngMerged.MergeCells Then
                    sÁrea = rngMerged.MergeArea.Address
                    sFórmula = rngMerged.Formula
                    rngMerged.UnMerge
                    For Each rng In .Range(sÁrea)
                        rng.Formula = sFórmula
                    Next rng
                End If
            Next rngMerged
        End With
        'fim
        
        LinhaEscreve = 3 'Define que a partir da linha 3 sera gravado os dados
            
        For iLinha = 3 To Qtde
           
            For iColuna = 4 To QtdeCol 'Percorrer a partir da coluna 4
            
                'Verifica se a celula em que se localiza o for é diferente de Nulo
                If Worksheets(mySheet1).Cells(iLinha, iColuna).Value <> "" Then
                   Worksheets(mySheet1).Cells(iLinha, iColuna).Value = Worksheets(mySheet1).Cells(2, iColuna).Value
                
                'Copiando/colando os dados conforme o laço for
                Worksheets(mySheet2).Cells(LinhaEscreve, 2).Value = Worksheets(mySheet1).Cells(iLinha, iColuna).Value
                Worksheets(mySheet2).Cells(LinhaEscreve, 3).Value = Worksheets(mySheet1).Cells(iLinha, 3).Value
                Worksheets(mySheet2).Cells(LinhaEscreve, 4).Value = Worksheets(mySheet1).Cells(iLinha, 2).Value
                Worksheets(mySheet2).Cells(LinhaEscreve, 1).Value = Worksheets(mySheet1).Cells(iLinha, 1).Value
                LinhaEscreve = LinhaEscreve + 1 'incremento adiciona mais uma linha
                End If
                                                                   
            Next iColuna
           
        Next iLinha
                    
        
        'voltar os valores X
        For cont1 = 3 To Qtde
           
            For cont2 = 4 To QtdeCol
            
                 If Not Worksheets(mySheet1).Cells(cont1, cont2).Value = "" Then
                 Worksheets(mySheet1).Cells(cont1, cont2) = "X"
                 End If
            Next cont2
           
        Next cont1
                            
        MsgBox "Fim"
        'fim
        
    End Sub
    
    
    
    
    

    segunda-feira, 5 de agosto de 2013 16:53

Todas as Respostas

  • Magdiel, seria mais fácil ajudar se você disponibilizasse para download sua pasta de trabalho para eu sugerir um código. Vendo apenas imagens fica muito difícil. Remova todo conteúdo confidencial.

    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    sexta-feira, 2 de agosto de 2013 23:04
    Moderador
  • Consegui desta forma:

        Dim iLinha As Integer
        Dim iColuna As Integer
        Dim cont1 As Integer
        Dim cont2 As Integer
        Dim Qtde As Long
        Dim vlCelulaBusca As Long
        Dim vlColunaBusca As Long
        Dim rngMerged As Range
        Dim rng As Range
        Dim sÁrea As String
        Dim sFórmula As String
    
    Sub buscar()
                
        mySheet1 = "mysheet" 'Defina qual sera a ABA ORIGEM
        mySheet2 = "mysheet" 'Defina qual sera a ABA DESTINO
            
        Worksheets(mySheet1).Select
                   
        'Percorre todas as linhas até encontrar a ultima que possiu valor
        vlCelulaBusca = Cells.Find(What:="*", After:=Range("A1"), _
                   SearchOrder:=xlByRows, _
                   SearchDirection:=xlPrevious).Row
                   
        'Percorre todas as coluna até encontrar a ultima que possiu valor
        vlColunaBusca = ActiveSheet.Cells.Find(What:="*", _
                           SearchDirection:=xlPrevious, _
                           SearchOrder:=xlByColumns).Column
                           
        Qtde = vlCelulaBusca
        QtdeCol = vlColunaBusca
        
        'tirar celulas mescladas
        With ActiveSheet
            For Each rngMerged In .UsedRange
                If rngMerged.MergeCells Then
                    sÁrea = rngMerged.MergeArea.Address
                    sFórmula = rngMerged.Formula
                    rngMerged.UnMerge
                    For Each rng In .Range(sÁrea)
                        rng.Formula = sFórmula
                    Next rng
                End If
            Next rngMerged
        End With
        'fim
        
        LinhaEscreve = 3 'Define que a partir da linha 3 sera gravado os dados
            
        For iLinha = 3 To Qtde
           
            For iColuna = 4 To QtdeCol 'Percorrer a partir da coluna 4
            
                'Verifica se a celula em que se localiza o for é diferente de Nulo
                If Worksheets(mySheet1).Cells(iLinha, iColuna).Value <> "" Then
                   Worksheets(mySheet1).Cells(iLinha, iColuna).Value = Worksheets(mySheet1).Cells(2, iColuna).Value
                
                'Copiando/colando os dados conforme o laço for
                Worksheets(mySheet2).Cells(LinhaEscreve, 2).Value = Worksheets(mySheet1).Cells(iLinha, iColuna).Value
                Worksheets(mySheet2).Cells(LinhaEscreve, 3).Value = Worksheets(mySheet1).Cells(iLinha, 3).Value
                Worksheets(mySheet2).Cells(LinhaEscreve, 4).Value = Worksheets(mySheet1).Cells(iLinha, 2).Value
                Worksheets(mySheet2).Cells(LinhaEscreve, 1).Value = Worksheets(mySheet1).Cells(iLinha, 1).Value
                LinhaEscreve = LinhaEscreve + 1 'incremento adiciona mais uma linha
                End If
                                                                   
            Next iColuna
           
        Next iLinha
                    
        
        'voltar os valores X
        For cont1 = 3 To Qtde
           
            For cont2 = 4 To QtdeCol
            
                 If Not Worksheets(mySheet1).Cells(cont1, cont2).Value = "" Then
                 Worksheets(mySheet1).Cells(cont1, cont2) = "X"
                 End If
            Next cont2
           
        Next cont1
                            
        MsgBox "Fim"
        'fim
        
    End Sub
    
    
    
    
    

    segunda-feira, 5 de agosto de 2013 16:53