Perguntas[excel](coding)

Sei que há muitas perguntas e respostas sobre o uso .selectdo erro 1004 para o objeto _Worksheet e segui cada uma delas da melhor maneira possível, especialmente nos dois links abaixo, mas não consigo descobrir o que há de errado com meu código.

Excel VBA, obtendo intervalo de uma planilha inativa

Como evitar o uso de Select no Excel VBA?

Continuo recebendo o erro "Método 'range' do objeto '_Worksheet' falhou". Da forma como vejo, não há necessidade de usar .Select ou .Activate no meu código, mas, por enquanto, só está funcionando usando-os.

Em uma nota lateral, ao usar .Select, o Application.ScreenUpdating = Falsenão parece funcionar e minha tela vai para cada planilha enquanto o código é executado. Alguma razão para isso?

Sub FormatWB()

Dim X As Long
Dim AA As Long
Dim Escopo As Worksheet
Dim Material As Worksheet
Dim PrecoMTL As Worksheet
Dim PrecoRev As Worksheet
Dim Orcamento As Worksheet

Set Escopo = ActiveWorkbook.Worksheets("Escopo")
Set Material = ActiveWorkbook.Worksheets("Material")
Set PrecoMTL = ActiveWorkbook.Worksheets("Preço Material")
Set PrecoRev = ActiveWorkbook.Worksheets("Preço Revestimento")
Set Orcamento = ActiveWorkbook.Worksheets("Orçamento Final")

Application.DisplayAlerts = False
Application.ScreenUpdating = False
 
    X = 4 'Initial Row

        Do Until IsEmpty(Escopo.Cells(X, "B"))
        

            'Escopo.Select
            
            With Escopo.Range(Cells(X, "A"), Cells(X, "Y"))
                .UnMerge
                .Borders.LineStyle = xlContinuous
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .NumberFormat = "@" 'Convert cell to text format
                .Font.Bold = False
                .Font.Italic = False
                .Font.Underline = False
                .Font.Name = "Calibri"
                .Font.Size = 11
                .Interior.ColorIndex = 0
                .Font.Color = vbBlack
            End With                                                    

            'Material.Select
            
            With Material.Range(Cells(X, "A"), Cells(X, "N"))
                .UnMerge
                .Borders.LineStyle = xlContinuous
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .NumberFormat = "@" 'Convert cell to text format
                .Font.Bold = False
                .Font.Italic = False
                .Font.Underline = False
                .Font.Name = "Calibri"
                .Font.Size = 11
                .Interior.ColorIndex = 0
                .Font.Color = vbBlack
            End With


            'PrecoMTL.Select
            
            With PrecoMTL.Range(Cells(X, "A"), Cells(X, "P"))
                .UnMerge
                .Borders.LineStyle = xlContinuous
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .NumberFormat = "@" 'Convert cell to text format
                .Font.Bold = False
                .Font.Italic = False
                .Font.Underline = False
                .Font.Name = "Calibri"
                .Font.Size = 11
                .Interior.ColorIndex = 0
                .Font.Color = vbBlack
            End With


            'PrecoRev.Select
            
            With PrecoRev.Range(Cells(X, "A"), Cells(X, "O"))
                .UnMerge
                .Borders.LineStyle = xlContinuous
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .NumberFormat = "@" 'Convert cell to text format
                .Font.Bold = False
                .Font.Italic = False
                .Font.Underline = False
                .Font.Name = "Calibri"
                .Font.Size = 11
                .Interior.ColorIndex = 0
                .Font.Color = vbBlack
            End With


            'Orcamento.Select
            
            With Orcamento.Range(Cells(X, "A"), Cells(X, "Q"))
                .UnMerge
                .Borders.LineStyle = xlContinuous
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .NumberFormat = "@" 'Convert cell to text format
                .Font.Bold = False
                .Font.Italic = False
                .Font.Underline = False
                .Font.Name = "Calibri"
                .Font.Size = 11
                .Interior.ColorIndex = 0
                .Font.Color = vbBlack
            End With
            
    X = X + 1
        Loop

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Tenho uma tabela do Excel dentro de uma planilha protegida. Estou tentando fazer os seguintes passos:

1. Adicione uma nova coluna chamada "decisão"
2. desbloquear as células dentro da coluna "decisão"
3. Filtrar a tabela com base nos valores de outra coluna "vendido" (se uma linha apresentar erro, mantenha-a visível e oculte todas as outras)
4. Aplique a validação de dados a todas as células visíveis para permitir apenas 2 valores "excluir" ou "classificar"

Tenho o seguinte código abaixo. Quando o executo, não recebo nenhum erro, mas não há validação nas células esperadas e as células não são desbloqueadas. Além disso, estou pensando que o desbloqueio provavelmente deve vir depois da filtragem, mas estou aberto a ideias.

    Private Sub HandleErrors()

    Dim ws, wsList As Worksheet
    Dim importTable As ListObject
    Dim DecisionColumn As ListColumn
    Dim listRange, valRange, cell As Range
    Dim listOptions As String

    Set ws = Worksheets("Sales Import")
    Set importTable = ws.ListObjects("Table_SalesImport")
    Set wsList = ThisWorkbook.Worksheets("Lists")
    Set listRange = wsList.Range("A1:A2")
    Set cell = ws.Range("W2")
    listOptions = "Delete, Classify"

    ws.Unprotect Password:=PassW

    With importTable

        ws.Unprotect Password:=PassW

        Set DecisionColumn = importTable.ListColumns.Add
        DecisionColumn.Name = "Select Decision"

        Range("W2").Select
        Set valRange = Range(cell, cell.End(xlDown))
        valRange.Locked = False
        valRange.Locked = False

        If .Parent.FilterMode Then .Range.AutoFilter
 
        .Range.AutoFilter Field:=22, Criteria1:="Error"

        With valRange.Validation
            .Delete 'delete previous validation
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
                Formula1:=listOptions
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = False

        End With

        Application.Run "Protect"

    End With

    End Sub

O fluxo de trabalho requer que o usuário, ao usar uma fonte de dados no Excel, selecione um ID exclusivo e clique em um botão que abrirá todos os PDFs em uma pasta de destino. Eu automatizei a localização da pasta de destino (há 10.000 subpastas) usando o ID exclusivo e uma data associada. Quero abrir todos os arquivos do diretório de destino em uma única instância do Acrobat.

O seguinte pode fazer um loop pelo diretório de destino e abrir todos os PDFs sem erros. Mas faz isso em instâncias distintas do Acrobat. Ou seja, se houver 5 PDFs, 5 instâncias do Acrobat serão abertas. Alguém pode, por favor, oferecer conselhos sobre um método que abriria todos os PDFs do diretório na mesma instância do Acrobat? Obrigado antecipadamente.

Sub OpenPDF1()

Dim path_to_exe As String
Dim floder_path As String
Dim pdf_to_open As String

pdf_to_open = ""

path_to_exe = "C:\\Program Files (x86)\\Adobe\\Acrobat Reader DC\\Reader\\AcroRd32.exe"

folder_path = "C:\\test1"

pdf_to_open = Dir(folder_path & "\*.pdf")

    Do While Len(pdf_to_open) > 0
        Shell path_to_exe & " " & folder_path & "\" & pdf_to_open
        pdf_to_open = Dir()
    Loop

End Sub

Estou tentando usar a seguinte sintaxe para abrir o local da pasta de trabalho ativa e selecionar o arquivo ao mesmo tempo:

Shell "C:\Windows\explorer.exe /select," & location, vbMaximizedFocus

Onde location é o caminho para a pasta de trabalho ativa

Funciona perfeitamente, exceto quando a pasta que estou tentando abrir contém uma vírgula no nome.

Por exemplo: C:\Usuários\q1Bossymess\CpSolution\CpSolution - Fairgrounds\06-2025 FY\Relatórios, Clínicos\08.25.24 AaSS.xlsx

Se eu copiar todo o caminho e colar na barra de endereços do Windows Explorer, ele abre a pasta sem problemas

O problema começa quando tento usar a Instrução Shell.

Se eu renomear a pasta de destino com a vírgula de "Relatórios Clínicos" para outra coisa, tudo funciona perfeitamente.

Não posso alterar o nome das pastas porque estou criando um complemento que será usado por pessoas diferentes em computadores diferentes e precisa funcionar sempre e em todas as circunstâncias.

Obrigado.

Acabei de descobrir qual é o problema alterando o nome da pasta para detectar o problema. Funciona perfeitamente quando o nome da pasta tem um "&" ou "-", mas não funciona com vírgulas no nome da pasta.

Minha expectativa é poder abrir qualquer pasta e destacar a pasta de trabalho ativa no Windows Explorer, o que funciona muito bem, exceto pelo problema da vírgula.

Alguém poderia me ajudar a resolver meu problema relacionado ao erro Procedimento Muito Grande no VBA?

Estou usando Private Sub Worksheet_Calculate()para ocultar e exibir linhas automaticamente e há 275 células que eu gostaria de definir para os gatilhos. O exemplo abaixo é mostrado apenas para 10 células de gatilhos, e eu gostaria de criar 275 células de gatilhos

Fragmento de código

`Private Sub Worksheet_Calculate()

    Set iCell = Range("G38")
    Set iCell2 = Range("G70")
    Set iCell3 = Range("G102")
    Set iCell4 = Range("G134")
    Set iCell5 = Range("G166")
    Set iCell6 = Range("G198")
    Set iCell7 = Range("G230")
    Set iCell8 = Range("G262")
    Set iCell9 = Range("G294")
    Set iCell10 = Range("G326")

    Application.EnableEvents = False

      byFALSE1Hidden = Rows("38:68").Hidden
    byTRUE1Hidden = Rows("10000:10000").Hidden

    ' New logic for trigger 2
    byFALSE2Hidden = Rows("70:100").Hidden
    byTRUE2Hidden = Rows("10001:10001").Hidden

    ' New logic for trigger 3
    byFALSE3Hidden = Rows("102:132").Hidden
    byTRUE3Hidden = Rows("10002:10002").Hidden

    ' New logic for trigger 4
    byFALSE4Hidden = Rows("134:164").Hidden
    byTRUE4Hidden = Rows("10003:10003").Hidden

    ' New logic for trigger 5
    byFALSE5Hidden = Rows("166:196").Hidden
    byTRUE5Hidden = Rows("10004:10004").Hidden

    ' New logic for trigger 6
    byFALSE6Hidden = Rows("198:228").Hidden
    byTRUE6Hidden = Rows("10005:10005").Hidden

    ' New logic for trigger 7
    byFALSE7Hidden = Rows("230:260").Hidden
    byTRUE7Hidden = Rows("10006:10006").Hidden

    ' New logic for trigger 8
    byFALSE8Hidden = Rows("262:292").Hidden
    byTRUE8Hidden = Rows("10007:10007").Hidden

    ' New logic for trigger 9
    byFALSE9Hidden = Rows("294:324").Hidden
    byTRUE9Hidden = Rows("10008:10008").Hidden

    ' New logic for trigger 10
    byFALSE10Hidden = Rows("326:356").Hidden
    byTRUE10Hidden = Rows("10009:10009").Hidden

    
    If iCell.value = "FALSE1" Then
        If Not byFALSE1Hidden Then
            Rows("38:68").Hidden = True
            Rows("10000:10000").Hidden = False
        End If
    ElseIf iCell.value = "TRUE1" Then
        If Not byTRUE1Hidden Then
            Rows("38:68").Hidden = False
            Rows("10000:10000").Hidden = True
         End If
    End If

'   New logic for trigger 2
    If iCell2.value = "FALSE2" Then
        If Not byFALSE2Hidden Then
            Rows("70:100").Hidden = True
            Rows("10001:10001").Hidden = False
        End If
    ElseIf iCell2.value = "TRUE2" Then
        If Not byTRUE2Hidden Then
            Rows("70:100").Hidden = False
            Rows("10001:10001").Hidden = True
         End If
    End If

'   New logic for trigger 3
    If iCell3.value = "FALSE3" Then
        If Not byFALSE3Hidden Then
            Rows("102:132").Hidden = True
            Rows("10002:10002").Hidden = False
        End If
    ElseIf iCell3.value = "TRUE3" Then
        If Not byTRUE3Hidden Then
            Rows("102:132").Hidden = False
            Rows("10002:10002").Hidden = True
         End If
    End If

'   New logic for trigger 4
    If iCell4.value = "FALSE4" Then
        If Not byFALSE4Hidden Then
            Rows("134:164").Hidden = True
            Rows("10003:10003").Hidden = False
        End If
    ElseIf iCell4.value = "TRUE4" Then
        If Not byTRUE4Hidden Then
            Rows("134:164").Hidden = False
            Rows("10003:10003").Hidden = True
         End If
    End If

'   New logic for trigger 5
    If iCell5.value = "FALSE5" Then
        If Not byFALSE5Hidden Then
            Rows("166:196").Hidden = True
            Rows("10004:10004").Hidden = False
        End If
    ElseIf iCell5.value = "TRUE5" Then
        If Not byTRUE5Hidden Then
            Rows("166:196").Hidden = False
            Rows("10004:10004").Hidden = True
         End If
    End If

'   New logic for trigger 6
    If iCell6.value = "FALSE6" Then
        If Not byFALSE6Hidden Then
            Rows("198:228").Hidden = True
            Rows("10005:10005").Hidden = False
        End If
    ElseIf iCell6.value = "TRUE6" Then
        If Not byTRUE6Hidden Then
            Rows("198:228").Hidden = False
            Rows("10005:10005").Hidden = True
         End If
    End If

'   New logic for trigger 7
    If iCell7.value = "FALSE7" Then
        If Not byFALSE7Hidden Then
            Rows("230:260").Hidden = True
            Rows("10006:10006").Hidden = False
        End If
    ElseIf iCell7.value = "TRUE7" Then
        If Not byTRUE7Hidden Then
            Rows("230:260").Hidden = False
            Rows("10006:10006").Hidden = True
         End If
    End If

'   New logic for trigger 8
    If iCell8.value = "FALSE8" Then
        If Not byFALSE8Hidden Then
            Rows("262:292").Hidden = True
            Rows("10007:10007").Hidden = False
        End If
    ElseIf iCell8.value = "TRUE8" Then
        If Not byTRUE8Hidden Then
            Rows("262:292").Hidden = False
            Rows("10007:10007").Hidden = True
         End If
    End If

'   New logic for trigger 9
    If iCell9.value = "FALSE9" Then
        If Not byFALSE9Hidden Then
            Rows("294:324").Hidden = True
            Rows("10008:10008").Hidden = False
        End If
    ElseIf iCell9.value = "TRUE9" Then
        If Not byTRUE9Hidden Then
            Rows("294:324").Hidden = False
            Rows("10008:10008").Hidden = True
         End If
    End If

'   New logic for trigger 10
    If iCell10.value = "FALSE10" Then
        If Not byFALSE10Hidden Then
            Rows("326:356").Hidden = True
            Rows("10009:10009").Hidden = False
        End If
    ElseIf iCell10.value = "TRUE10" Then
        If Not byTRUE10Hidden Then
            Rows("326:356").Hidden = False
            Rows("10009:10009").Hidden = True
         End If
    End If


    Application.EnableEvents = True

End Sub

Obrigado.

Estou tentando criar uma função personalizada para preencher células selecionadas com números aleatórios exclusivos. Meu problema é obter o intervalo de células selecionadas, por exemplo.

=randm()

Meu problema é que não sei o intervalo de células a preencher

Preciso obter o endereço do intervalo H16:J24

É possível ?

Cumprimentos.

Parece que chamar uma função com um array como parâmetro não atualiza o array (chamada por ref) se um valor de retorno não for usado. Isso é um bug ou estou esquecendo de algo aqui? Uma pequena macro de teste com a saída gerada abaixo:

Sub Makro1()
'
' Makro1 Makro
'
' Kortkommando: Ctrl+t
'
    Dim xyzArray() As Double
    ReDim xyzArray(1 To 3)
    xyzArray(1) = 1
    xyzArray(2) = 2
    xyzArray(3) = 3
    
    Range("D2:F2").Value = xyzArray
    
    TestFunction (xyzArray)
    Range("D3:F3").Value = xyzArray
    
    newXYZ = TestFunction(xyzArray)
    Range("D4:F4").Value = xyzArray
    
    TestSub xyzArray
    Range("D5:F5").Value = xyzArray
    
    TestFunction (xyzArray)
    Range("D6:F6").Value = xyzArray

    TestFunctionNoReturn (xyzArray)
    Range("D7:F7").Value = xyzArray
  
End Sub

Private Function TestFunction(XYZ) As Double()
    XYZ(1) = XYZ(1) + 1
    XYZ(2) = XYZ(2) + 1
    XYZ(3) = XYZ(3) + 1
    TestFunction = XYZ
End Function

Private Sub TestSub(XYZ)
    XYZ(1) = XYZ(1) + 1
    XYZ(2) = XYZ(2) + 1
    XYZ(3) = XYZ(3) + 1
End Sub

Private Function TestFunctionNoReturn(XYZ) As Double()
    XYZ(1) = XYZ(1) + 1
    XYZ(2) = XYZ(2) + 1
    XYZ(3) = XYZ(3) + 1
End Function

[SAÍDA]

Devido à forma como um formulário é configurado, toda vez que um usuário preenche o formulário, diferentes informações trimestrais são armazenadas em uma única linha. Para fins de análise de dados e simplicidade, eu gostaria de "transpor e mesclar" as colunas com as mesmas informações. Neste caso, todas as colunas contendo informações de **trimestre **e informações de **valor**.

Tenho a seguinte tabela:

Quero transpor as colunas Quarter e seus respectivos valores e gerar o seguinte:

Tentei transpor as colunas, mas acabei fazendo uma bagunça e várias linhas.

Tenho dados de certas Linhas e Colunas. Preciso converter todas as colunas uma após a seguinte.

=LET(a,A2:A11,cn,COUNTA(B2:D2),_a,TEXTSPLIT(REPT(TEXTJOIN(",",,a)&"$",cn),,{",","$"},1),_a)

Tentei várias maneiras de obter outras colunas (ID, Região, WC) uma após a outra, conforme mostrado na imagem, mas não consegui.

Qualquer ajuda será muito apreciada.

Obrigado.

Quero adicionar uma planilha usando as 2 primeiras células de uma tabela como seu nome. Por exemplo, na tabela a seguir, o Botão 1 criaria uma planilha chamada "Doe,John".

O código do botão se parece com o seguinte atualmente, trazendo uma caixa de entrada para inserir manualmente um nome, abrindo-o e, em seguida, classificando as planilhas em ordem alfabética. Se a planilha já existir, ele só abrirá a planilha:

Sub TestSheetCreate()
    Dim newSheetName As String
    Dim checkSheetName As String
    Dim I As Integer
    Dim J As Integer
    
    newSheetName = Application.InputBox("Input Sheet Name:", "Excel 10 Tutorial", "", , , , , 2)

    On Error Resume Next

    checkSheetName = Worksheets(newSheetName).Name

    If checkSheetName = "" Then
        Worksheets.Add.Name = newSheetName
    Else
        Sheets(checkSheetName).Select
    End If

    For I = 1 To Sheets.Count - 1
        For J = I + 1 To Sheets.Count
            If UCase(Sheets(I).Name) > UCase(Sheets(J).Name) Then
                Sheets(J).Move Before:=Sheets(I)
            End If
        Next J
    Next I
    
End Sub

Como eu substituiria o InputBox por um nome automático gerado a partir das 2 primeiras células da linha em que o botão está localizado?