VBA que procura célula para colar valor

[aninha_27]

Olá!

Tenho um relatório em que o número de linhas irá variar, preciso fazer um somatório da coluna AO, depois verificar nas colunas D e E o código do produto e com base nesse código colar o valor da soma em outra aba na linha correspondente a este código. Por exemplo, se na coluna D está R1 e na coluna E está o código 69, na aba em que o valor da soma será colado, a macro deve procurar a linha que contém esses códigos e colar o valor na coluna P, na outra aba esses códigos devem ser procurados nas colunas C e D.

Já fiz o código cravando a célula, mas desse jeito não me atende...

    Range("AO2").Select
    Dim DLin As Long
    DLin = Range("AO2").End(xlDown).Row + 1
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-1335]C:R[-2]C)"
    Selection.Copy
    Windows("Sugestão_01.xlsx").Activate
    Range("P3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

 

Por gentileza, alguém pode ajudar?

Desde já obrigada!

Editado Julho 11, 2018 por aninha_27

[Erik Wesley]

4 horas atrás, aninha_27 disse:

Erik, será que você pode ajudar com essa macro?

Ok. Me diga sua necessidade, mas de uma forma simplificada.

[aninha_27]

'Referências
Dim Ref As String
Dim Ref2 As String
Dim Ref3 As String

'Copiar relatório para planilha
    Cells.Select
    Selection.Copy
    Windows("TESTE FILTRO.xlsm").Activate
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

'Texto para colunas
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="|", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True

'Excluir linhas de 1 até 9
    Rows("1:10").Select
    Selection.Delete Shift:=xlUp
 
'Substituir espaço por nada
    Columns("D:D").Select
    Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
'Inserir colunas
    Columns("F:H").Select
    Selection.Insert Shift:=xlToRight
    
'Inserir fórmulas TEXTO e CONCATENAR
    Range("F2").Select
    ActiveCell.FormulaR1C1 = "=TEXT(RC[-2],""00"")"
    Range("F2").Select
    Selection.AutoFill Destination:=Range("F2:G2"), Type:=xlFillDefault
    Range("F2:G2").Select
    Range("H2").Select
    ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-2],RC[-1])"
    Range("F2:H2").Select
    Selection.Copy
    Range("E2").Select
    Selection.End(xlDown).Select
    Range("F" & Selection.Row).Select
    Range(Selection, Selection.End(xlUp)).Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("D1:E1").Select
    Selection.Copy
    Range("F1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
'Inserir filtro
    Rows("1:1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$AY$1048576").AutoFilter Field:=50, Criteria1:=Array( _
        "10", "15", "50", "60", "80"), Operator:=xlFilterValues

'Inserindo subtotais
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    Worksheets("Planilha2").Select
        'Windows("Pasta1.xlsm").Activate
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Subtotal GroupBy:=8, Function:=xlSum, TotalList:=Array(44, 45), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
        
'Copiando subtotais
    Columns("I:AQ").Select
    Range("AQ1").Activate
    Selection.EntireColumn.Hidden = True
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "CONCATENAR"
    Range("H2").Select
    ActiveSheet.Outline.ShowLevels RowLevels:=2
    Range("H1:AS1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    'Sheets.Add After:=ActiveSheet
    Worksheets("Planilha3").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("A:A").Select
    Range("B2").Select
    Ref = ActiveCell.Value

'Setar referências
Worksheets("Planilha1").Select
Range("D2").Select
Ref2 = ActiveCell.Value

Range("E2").Select
Ref3 = ActiveCell.Value

'Range("AO1").Select
'Ref = ActiveCell.Value

'Abrir Arquivo Faturamento
Windows("Faturamento_2018.xlsm").Activate
Range("A3").Select

'Busca as referências na planilha Faturamento
Do
Do
If ActiveCell.Value <> Ref2 Then
ActiveCell.Offset(1, 0).Select
End If
Loop Until ActiveCell.Value = Ref2
ActiveCell.Offset(0, 1).Select
If ActiveCell.Value <> Ref3 Then
ActiveCell.Offset(0, -1).Select
ActiveCell.Offset(1, 0).Select
End If
Loop Until ActiveCell.Value = Ref3

'Caso encontre
ActiveCell.Offset(0, 14).Select
ActiveCell.Value = Ref

'Segunda parte para colar
Windows("TESTE FILTRO.xlsm").Activate
Range("C2").Select
Ref = ActiveCell.Value
    
Worksheets("Planilha1").Select
Range("D2").Select
Ref2 = ActiveCell.Value

Range("E2").Select
Ref3 = ActiveCell.Value

'Range("AO1").Select
'Ref = ActiveCell.Value

'Abrir Arquivo Faturamento
Windows("Faturamento_2018.xlsm").Activate
Range("A3").Select

'Busca as referências na planilha Faturamento
Do
Do
If ActiveCell.Value <> Ref2 Then
ActiveCell.Offset(1, 0).Select
End If
Loop Until ActiveCell.Value = Ref2
ActiveCell.Offset(0, 1).Select
If ActiveCell.Value <> Ref3 Then
ActiveCell.Offset(0, -1).Select
ActiveCell.Offset(1, 0).Select
End If
Loop Until ActiveCell.Value = Ref3

'Caso encontre
ActiveCell.Offset(0, 15).Select
ActiveCell.Value = Ref

End Sub

 

Este é o código, o problema que está ocorrendo é quando vai colar a informação.

Ele está retirando a vírgula do número, por exemplo, o número que deveria ser colado é esse 987580,70 porém a macro retira a vírgula e cola o número desta forma 98758070.

Desde já obrigada!

[Erik Wesley]

15 horas atrás, aninha_27 disse:

'Referências
Dim Ref As String
Dim Ref2 As String
Dim Ref3 As String

'Copiar relatório para planilha
    Cells.Select
    Selection.Copy
    Windows("TESTE FILTRO.xlsm").Activate
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

'Texto para colunas
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="|", FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True

'Excluir linhas de 1 até 9
    Rows("1:10").Select
    Selection.Delete Shift:=xlUp
 
'Substituir espaço por nada
    Columns("D:D").Select
    Selection.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
'Inserir colunas
    Columns("F:H").Select
    Selection.Insert Shift:=xlToRight
    
'Inserir fórmulas TEXTO e CONCATENAR
    Range("F2").Select
    ActiveCell.FormulaR1C1 = "=TEXT(RC[-2],""00"")"
    Range("F2").Select
    Selection.AutoFill Destination:=Range("F2:G2"), Type:=xlFillDefault
    Range("F2:G2").Select
    Range("H2").Select
    ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[-2],RC[-1])"
    Range("F2:H2").Select
    Selection.Copy
    Range("E2").Select
    Selection.End(xlDown).Select
    Range("F" & Selection.Row).Select
    Range(Selection, Selection.End(xlUp)).Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("D1:E1").Select
    Selection.Copy
    Range("F1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
'Inserir filtro
    Rows("1:1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$AY$1048576").AutoFilter Field:=50, Criteria1:=Array( _
        "10", "15", "50", "60", "80"), Operator:=xlFilterValues

'Inserindo subtotais
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    Worksheets("Planilha2").Select
        'Windows("Pasta1.xlsm").Activate
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Subtotal GroupBy:=8, Function:=xlSum, TotalList:=Array(44, 45), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
        
'Copiando subtotais
    Columns("I:AQ").Select
    Range("AQ1").Activate
    Selection.EntireColumn.Hidden = True
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "CONCATENAR"
    Range("H2").Select
    ActiveSheet.Outline.ShowLevels RowLevels:=2
    Range("H1:AS1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    'Sheets.Add After:=ActiveSheet
    Worksheets("Planilha3").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("A:A").Select
    Range("B2").Select
    Ref = ActiveCell.Value

'Setar referências
Worksheets("Planilha1").Select
Range("D2").Select
Ref2 = ActiveCell.Value

Range("E2").Select
Ref3 = ActiveCell.Value

'Range("AO1").Select
'Ref = ActiveCell.Value

'Abrir Arquivo Faturamento
Windows("Faturamento_2018.xlsm").Activate
Range("A3").Select

'Busca as referências na planilha Faturamento
Do
Do
If ActiveCell.Value <> Ref2 Then
ActiveCell.Offset(1, 0).Select
End If
Loop Until ActiveCell.Value = Ref2
ActiveCell.Offset(0, 1).Select
If ActiveCell.Value <> Ref3 Then
ActiveCell.Offset(0, -1).Select
ActiveCell.Offset(1, 0).Select
End If
Loop Until ActiveCell.Value = Ref3

'Caso encontre
ActiveCell.Offset(0, 14).Select
ActiveCell.Value = Ref

'Segunda parte para colar
Windows("TESTE FILTRO.xlsm").Activate
Range("C2").Select
Ref = ActiveCell.Value
    
Worksheets("Planilha1").Select
Range("D2").Select
Ref2 = ActiveCell.Value

Range("E2").Select
Ref3 = ActiveCell.Value

'Range("AO1").Select
'Ref = ActiveCell.Value

'Abrir Arquivo Faturamento
Windows("Faturamento_2018.xlsm").Activate
Range("A3").Select

'Busca as referências na planilha Faturamento
Do
Do
If ActiveCell.Value <> Ref2 Then
ActiveCell.Offset(1, 0).Select
End If
Loop Until ActiveCell.Value = Ref2
ActiveCell.Offset(0, 1).Select
If ActiveCell.Value <> Ref3 Then
ActiveCell.Offset(0, -1).Select
ActiveCell.Offset(1, 0).Select
End If
Loop Until ActiveCell.Value = Ref3

'Caso encontre
ActiveCell.Offset(0, 15).Select
ActiveCell.Value = Ref

End Sub

 

Este é o código, o problema que está ocorrendo é quando vai colar a informação.

Ele está retirando a vírgula do número, por exemplo, o número que deveria ser colado é esse 987580,70 porém a macro retira a vírgula e cola o número desta forma 98758070.

Desde já obrigada!

Qual a parte que está copiando?

[aninha_27]

'Copiando subtotais
    Columns("I:AQ").Select
    Range("AQ1").Activate
    Selection.EntireColumn.Hidden = True
    Range("H1").Select
    ActiveCell.FormulaR1C1 = "CONCATENAR"
    Range("H2").Select
    ActiveSheet.Outline.ShowLevels RowLevels:=2
    Range("H1:AS1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    'Sheets.Add After:=ActiveSheet
    Worksheets("Planilha3").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("A:A").Select
    Range("B2").Select
    Ref = ActiveCell.Value > ESSA PARTE COPIA

'Setar referências
Worksheets("Planilha1").Select
Range("D2").Select
Ref2 = ActiveCell.Value > AQUI VERIFICA UM DOS CÓDIGOS QUE TEM QUE PROCURAR NA OUTRA PLANILHA PARA COLAR A INFORMAÇÃO ACIMA "REF"

Range("E2").Select
Ref3 = ActiveCell.Value >>> AQUI VERIFICA O OUTRO CÓDIGO QUE TEM QUE PROCURAR NA OUTRA PLANILHA PARA COLAR A INFORMAÇÃO ACIMA "REF"

'Range("AO1").Select
'Ref = ActiveCell.Value

'Abrir Arquivo Faturamento
Windows("Faturamento_2018.xlsm").Activate
Range("A3").Select

'Busca as referências na planilha Faturamento
Do
Do
If ActiveCell.Value <> Ref2 Then
ActiveCell.Offset(1, 0).Select
End If
Loop Until ActiveCell.Value = Ref2
ActiveCell.Offset(0, 1).Select
If ActiveCell.Value <> Ref3 Then
ActiveCell.Offset(0, -1).Select
ActiveCell.Offset(1, 0).Select
End If
Loop Until ActiveCell.Value = Ref3

'Caso encontre
ActiveCell.Offset(0, 14).Select
ActiveCell.Value = Ref > AQUI COLA NO LUGAR CERTO

 

Entendeu?

[aninha_27]

Bom dia Erik! Tudo bem?

Você sabe me dizer se na hora de buscar as referências o código acima pode se perder quando é 01 (formato texto)?

Por exemplo, na guia "planilha3", o código copia um valor, vai na guia "planilha2" e verifica dois códigos nas colunas D e E, esses códigos a macro vai procurar na outra planilha para colar na linha correta!

Mas veja só, quando o código é por exemplo AA (D2) e 01 (E2) funciona perfeitamente, porém quando o código é um número, dá erro, por exemplo 01 (D2) e 01 (E2). Para aparecer desta forma o número > 01 está formatado como texto, senão apareceria 1 no excel.

Pode me ajudar?

Desde já obrigada!