Excel Fórmula VLOOKUP utilizando uma Variant no VBA

[Bruno Rimoldi]

Bom dia pessoal, espero que estejam bem.

 

Estou terminando uma macro que ao Clicar em um botão (Start Item a Item) é aberto uma caixa onde seleciono um arquivo para fazer um outro processo. Esse arquivo fica aberto até terminar esse processo. Eu preciso fazer um Vlookup e no meio da fórmula preciso chamar o nome do arquivo aberto que está em uma Variant (Filename). Porém quando a macro executa a fórmula aparece o caminho todo e está muito demorado. Preciso que só pegue o nome do arquivo e coloque na fórmula. Lembrando que todo mês o nome irá alterar, por isso de armazenar em uma Variant.

 

1-) A fórmula é a seguinte: "=VLOOKUP(RC[-5],'" & Filename & "'!C35:C147,113,1)"

 

2-) Outro ponto é no filtro que eu faço. Queria que chamasse a Sheet1 ao invés do nome (em vermelho):
ActiveWorkbook.Worksheets("Item a Item Julho 2022").AutoFilter.Sort.SortFields.Clear

 

Sub ItemItem()

    Dim Filename As String
    Dim SrcWkb As Workbook
    Dim Ws As Worksheet
    
    ThisWorkbook.Activate
    
    Filename = Application.GetOpenFilename _
    (Title:="Selecione o Arquivo Item a Item", _
    FileFilter:="Excel Files *.xls* (*.xls*),")
    
    If Filename = "Falso" Then
        MsgBox "Formato incompatível do arquivo" _
        , vbCritical _
        , "Erro!"
        Exit Sub
    Else
        
        sFileName = Application.ThisWorkbook.Name
        
        Application.DisplayAlerts = False
                
        Set SrcWkb = Excel.Workbooks.Open(Filename, True, True)
        SrcWkb.Worksheets(1).Activate
        Set Ws = SrcWkb.Worksheets(1)
        
        With Sheet2
        Rows("5:5").Select
        Selection.AutoFilter
    ActiveWorkbook.Worksheets("Item a Item Julho 2022").AutoFilter.Sort.SortFields. _
        Clear
    ActiveWorkbook.Worksheets("Item a Item Julho 2022").AutoFilter.Sort.SortFields. _
        Add2 Key:=Range("EQ5:EQ100000"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Item a Item Julho 2022").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Worksheets("Item a Item Julho 2022").AutoFilter.Sort.SortFields. _
        Clear
    ActiveWorkbook.Worksheets("Item a Item Julho 2022").AutoFilter.Sort.SortFields. _
        Add2 Key:=Range("AI5:AI100000"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Item a Item Julho 2022").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
        
            .Activate
                Sheets("IR").Select
                linha = 2
                Do While Sheet2.Range("A" & linha) <> ""
                        Sheet2.Range("F" & linha).Formula = "=VLOOKUP(RC[-5],'" & Filename & "'!C35:C147,113,1)"
                        linha = linha + 1
                Loop
                
                Columns("F:F").Select
                Selection.Copy
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                Application.CutCopyMode = False
                Range("A1").Select
                
                Sheets("INSS").Select
                LR1 = Range("A:A").SpecialCells(xlCellTypeLastCell).Row
                linha1 = 2
                Do While Sheet3.Range("A" & linha1) <> ""
                        Sheet3.Range("F" & linha1).Formula = "=VLOOKUP(RC[-5],'" & Filename & "'!C35:C147,113,1)"
                        linha1 = linha1 + 1
                Loop
                Columns("F:F").Select
                Selection.Copy
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                Application.CutCopyMode = False
                Range("A1").Select
                
                Sheets("ISS").Select
                LR2 = Range("A:A").SpecialCells(xlCellTypeLastCell).Row
                linha2 = 2
                Do While Sheet4.Range("A" & linha2) <> ""
                        Sheet4.Range("F" & linha2).Formula = "=VLOOKUP(RC[-5],'" & Filename & "'!C35:C147,113,1)"
                        linha2 = linha2 + 1
                Loop
                Columns("F:F").Select
                Selection.Copy
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                Application.CutCopyMode = False
                Range("A1").Select
                    
        End With
        
        If Not SrcWkb Is Nothing Then
            SrcWkb.Close False
            Set SrcWkb = Nothing
            Set Ws = Nothing
        End If
    End If
    
            Application.DisplayAlerts = True
            
            MsgBox "Item a Item OK!!!"

End Sub

 

Macro_IDF_NUM - Copia.zip

[AfonsoMira]

Boas @Bruno Rimoldi ,

Veja se ajuda:
 

Set fso = CreateObject("Scripting.FileSystemObject")
ficheiro = fso.getFileName(Filename)

 

"=VLOOKUP(RC[-5],'" & ficheiro & "'!C35:C147,113,1)"

 

[Bruno Rimoldi]

@AfonsoMira muito obrigado pela ajuda. Aprendi mais uma.

 

Outro ponto é no filtro que eu faço. Queria que chamasse a Sheet1 ao invés do nome da Sheet (em vermelho):
ActiveWorkbook.Worksheets("Item a Item Julho 2022").AutoFilter.Sort.SortFields.Clear

 

Tem como?

[Bruno Rimoldi]

Bom dia, consegui resolver de uma forma mais simples.

 

Outro ponto é no filtro que eu faço. Queria que chamasse a Sheet1 ao invés do nome da Sheet (em vermelho):
ActiveWorkbook.Worksheets("Item a Item Julho 2022").AutoFilter.Sort.SortFields.Clear

 

Inseri a palavra TESTE na célula B5 e utilizei o código abaixo. E no filtro deixei como padrão o TESTE:

ActiveWorkbook.Worksheets("TESTE").AutoFilter.Sort.SortFields.Clear

Dim rs As Worksheet

  For Each rs In Sheets
  	rs.Name = rs.Range("B5")
  Next rs