Localizar e copiar dados de abas

Question

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 

Answer 1

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

Answer 2

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