Basole

@BlackM00n_ Poste exemplos de arquivos, para que possamos entender melhor sua demanda.

@Telma Raizlatina por favor, anexe um exemplo do seu arquivo, para que possamos entender melhor e ajudar com sua demanda.

Pode ser que o caminho do arquivo seja longo e o windows não esta conseguindo ler por completo. Experimente usar esta funcão para "abreviar" o caminho. Use: GetShortPath(SeuCaminho\SeuArquivo) Public Function GetShortPath(path As String) As String Dim fso As Object If fso Is Nothing Then Set fso = CreateObject("Scripting.FileSystemObject") End If If fso.FileExists(path) Then GetShortPath = fso.GetFile(path).ShortPath Exit Function End If If fso.FolderExists(path) Then GetShortPath = fso.GetFolder(path).ShortPath Set fso = Nothing Exit Function End If End Function

@viclizz somente com imagens dos árquivos fica difícil te ajudar, dando um parecer. Seria bom se pudesse anexar amostra dos arquivos que serão copiados, originais ou exemplos similares.

De acordo com as informações passadas e as imagens, segue um exemplo *Copie e cole o codigo abaixo em um modulo padrão na sua pasta de trabalho Destino. Sub Copiar_e_Colar_de_Arquivos_Diferentes() 'Por Basole 01/08/19 Dim Filename As String Dim sDia As Single Dim sMes As String Dim xlCopy As Single Dim fldr As FileDialog Dim sItem As String On Error GoTo Erro Excel.Application.ScreenUpdating = False Set fldr = Application.FileDialog(msoFileDialogFolderPicker) With fldr .Title = "Selecione a Pasta que Deseja Copiar os Arquivos" .AllowMultiSelect = False .InitialFileName = Application.DefaultFilePath If .Show <> -1 Then Exit Sub sItem = .SelectedItems(1) End With sMes = InputBox("No formato Numerico dois digitos -> 00", _ "Informe o mes dos repectivos nomes dos arquivos") For sDia = 1 To 31 Filename = VBA.Format(sDia, "00") & VBA.Format(sMes, "00") & VBA.Format(Date, "yy") & _ ".xlsx" If VBA.Dir(sItem & "\" & Filename) <> "" Then Excel.Workbooks.Open Filename:=sItem & "\" & Filename, ReadOnly:=True LastRow = ActiveSheet.Cells.Find("*", SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row With ThisWorkbook.ActiveSheet ActiveSheet.Range("A1:D" & LastRow).Copy .Cells(.Rows.Count, "A"). _ End(xlUp).Offset(1, 0) xlCopy = xlCopy + 1 Excel.Workbooks(Filename).Close End With End If Next If xlCopy > 0 Then MsgBox xlCopy & " Arquivos foram copiados do mês " & _ sMes, 64, " S u c e s s o " Erro: Excel.Application.ScreenUpdating = True End Sub

Envie amostras de arquivos que quer importar os dados e o arquivo que receberá

Nesta tela do editor do vbe do Excel, aperte as teclas ctrl+g na tela imediata: Digite debug.Print excel.Application.StartupPath e pressione ENTER. Deve aparecer um caminho de diretorio ,mais ou menos assim: C:\Users\User\AppData\Roaming\Microsoft\Excel\XLINÍCIO Cole este endereco no explorer e pressione ENTER. E delete os arquivos desta pasta que abrir.

Abra o Excel em uma nova pasta de trabalho, crie um modulo e cole o codigo abaixo: Sub Teste() Dim myDir As String Dim fn As String Dim wb As Workbook Set wb = ActiveWorkbook With Application.FileDialog(msoFileDialogFolderPicker) If .Show Then myDir = .SelectedItems(1) & "\" End With If myDir = "" Then Exit Sub fn = VBA.Dir(myDir & "*.csv") Do While fn <> "" With Workbooks.Open(myDir & fn) .Sheets(1).Copy after:=wb.Sheets(wb.Sheets.Count) .Close False End With fn = Dir Loop End Sub O codigo importa todos os arquivos *.CSV selecionados, em abas diferentes, nomeando-as de acordo com o nome do arquvio.

Veja esta opcão, se lhe atende. Conforme imagem acima, veja como acessar os recursos 1- Click a direita da imagem, na Aba Prime Clean 2- A Esquerda da imagem, as opcões de navegacão (Selecionar uma aba [visível], Ordenar/ Classificar as abas, Selecionar uma aba oculta, Ocultar a aba ativa). DASHBOARD DE RECRUTAMENTO.zip

Tem sim. Segue o codigo completo, com as alteracoes solicitadas... Sub Duplicar_e_Renomear() Dim Rng As Range Dim newName As String Dim newSheet As Worksheet With ThisWorkbook Set newSheet = .Sheets.Add(After:= _ .Sheets(.Sheets.Count)) With .Sheets("Movimento do Dia") Set Rng = .Range(.Cells(1, 1), .Cells(28, 5)) Rng.Copy With newSheet.Range("A1") .PasteSpecial Paste:=xlPasteAll .PasteSpecial Paste:=xlPasteColumnWidths End With Set Rng = .Range(.Cells(1, 9), .Cells(2, 15)) Rng.Copy With newSheet.Range("I1") .PasteSpecial Paste:=xlPasteAll .PasteSpecial Paste:=xlPasteColumnWidths End With Excel.Application.CutCopyMode = False On Error GoTo Erro newName = InputBox("O nome do backup é:", "Renomeando...", newSheet.Name) newSheet.Name = newName End With End With MsgBox "Backup Realizado com Sucesso!!!", 64, Sucesso Exit Sub Erro: MsgBox Err.Description, 16 On Error GoTo 0 End Sub

@Juliana.souza tem sim. Segue exemplo em anexo. Inserir_Imagem_ActiveX.zip

@R de Freitas Como eu disse, nao tenho o Adobe pro, sendo assim nao posso testar e dar uma opiniao, pois podem ser varias coisas que estão interferindo no funcionamento do codigo de exemplo. De qualquer forma, veja se este outro exemplo lhe atende e ai adapta a sua planilha e seu formulário. Formulario_PDF.zip * Quem nao tem o adobe-pro e quiser testar pode imprimir os formularios gerados ou instalar uma impressora virtual, como por exemplo CutePDF Writer

Segue em anexo um exemplo de automatizacao * Nao testado, pois nao tenho o adobe-pro instalado Exemplo_PDF_Form.zip

Bom pelo que entendi voce quer criar uma nova aba e copiar os intervalos citados da aba "Movimento do Dia", criando um backup. Segue alteracao: Sub Duplicar_e_Renomear() Dim Rng As Range Dim newName As String Dim newSheet As Worksheet With ThisWorkbook Set newSheet = .Sheets.Add(After:= _ .Sheets(.Sheets.Count)) With .Sheets("Movimento do Dia") Set Rng = .Range(.Cells(1, 1), .Cells(28, 5)) Rng.Copy Destination:=newSheet.Range("A1") Set Rng = .Range(.Cells(1, 9), .Cells(2, 15)) Rng.Copy Destination:=newSheet.Range("I1") On Error GoTo Erro newName = InputBox("O nome do backup é:", "Renomeando...", newSheet.Name) newSheet.Name = newName End With End With MsgBox "Backup Realizado com Sucesso!!!", 64, Sucesso Exit Sub Erro: MsgBox Err.Description, 16 On Error GoTo 0 End Sub

É possivel através do Adobe Pro + VBA . Caso ao tenha o Adobe pro, outra opcao é o FoxitReader é um software gratuito, que você pode usar para importar ou exportar dados de um formulário PDF.

Fiz as alteracoes solicitadas. Veja se é isso: Sub Duplicar_e_Renomear() Dim Rng As Range Dim newSheet As Worksheet Set Rng = Sheets("Movimento do Dia").Range("A1:E28") Set newSheet = ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count) Rng.Copy Destination:=newSheet.Range("A1") newSheet.Name = InputBox("O nome do backup é:", "Renomeando...", newSheet.Name) MsgBox "Backup Realizado com Sucesso!!!" End Sub

Uma opcao seria, inserir as textbox dinamicamente, criando a grid, de acordo com o intervalo (coluna X Linhas). Veja este exemplo: Dynamically Add Controls to a Form with Visual Basic 6.0

Segue com a alteração solicitada. Private Sub Worksheet_Activate() Dim ws As Worksheet, i As Integer Application.ScreenUpdating = False Sheets("ListaPlans").Range("A:B").ClearContents For Each ws In ThisWorkbook.Worksheets If ws.Name <> "ListaPlans" Then If ws.Visible = xlSheetVisible Then i = i + 1 With Sheets("ListaPlans") .Range("A" & i) = ws.Name .Hyperlinks.Add Anchor:=Range("A" & i), _ Address:="", SubAddress:="'" & ws.Name & _ "'!A1", TextToDisplay:=ws.Name .Range("B" & i) = "=" & ws.Name & "!F6" End With End If End If Next ws Application.ScreenUpdating = True End Sub

Tente desta forma: Dim UltimaLinha As Long UltimaLinha = Range("H" & Rows.Count).End(xlUp).Row Range("H8:H" & UltimaLinha).Formula = "=NOW()-E8"

Sim eh possivel. Segue um exemplo. Ajuste no codigo no local indicado, de acordo com as caracteristicas dos seus arquivo excel e access. Sub EnviaComentariosExcelParaAccess() ' Ative as referências no editor do VB --> Ferramentas --> Referências --> Microsoft ActiveX Data Objects 6.1 Library ' Exporta dados dos comentarios da planilha ativa para uma tabela em um banco de dados do Access ' Este procedimento deve ser editado antes de usar Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long ' Conecta-se ao banco de dados do Access Set cn = New ADODB.Connection cn.Open "Provider=microsoft.ace.oledb.12.0; " & _ "Data Source=" & ThisWorkbook.Path & "\NOME_DA_SUA_TABELA_AQUI.accdb;" ' Abre um recordset Set rs = New ADODB.Recordset rs.Open "NOME_DA_SUA_TABELA_AQUI", cn, adOpenKeyset, adLockOptimistic, adCmdTable r = 1 'a linha inicial na planilha Do Until Range("A" & r).Comment Is Nothing ' Repete até a primeira célula vazia na coluna A With rs .AddNew 'criar um novo registro ' Adiciona comentarios a cada campo no registro On Error Resume Next .Fields("NOME_DO_CAMPO_1") = Range("A" & r).Comment.Text .Fields("NOME_DO_CAMPO_2") = Range("B" & r).Comment.Text .Fields("NOME_DO_CAMPO_3") = Range("C" & r).Comment.Text ' * Adicione mais campos, se necessário ... .Update ' armazena o novo registro End With r = r + 1 'proxima linha ... On Error GoTo 0 Loop rs.Close Set rs = Nothing cn.Close Set cn = Nothing End Sub

Use o excel

Sim, fazer pesquisa com a inserção de mais de uma variável em toda a aba, já é algo mais simples: 1º Insira + um textbox para inserir os termos de pesquisa. 2º renomeei para txtPesquisa A macro vai entender que os espaços é o que separa, os termos que deverão ser pesquisados 3º substitua o código abaixo do botão pesquisar Private Sub btnPesquisar_Click() Dim r As Range Dim O_Q() As String Dim arrLB As Variant Dim i As Integer Dim ws1 As Worksheet O_Q() = VBA.Split(Me.txtPesquisa.Text) ReDim arrLB(0, 11) Set ws1 = Plan16 With Me.ListBox1 .ColumnCount = 11 .ColumnWidths = "30;40;50;40;80;50;70;70;70;70;70" .List = arrLB .Clear For i = LBound(O_Q) To UBound(O_Q) If VBA.IsDate(O_Q(i)) Then Set r = FindAll(VBA.CDate(O_Q(i))) Else Set r = FindAll(O_Q(i)) End If If Not r Is Nothing Then .AddItem .List(.ListCount - 1, 0) = ws1.Range("A" & r.Row).Value .List(.ListCount - 1, 1) = ws1.Range("B" & r.Row).Value .List(.ListCount - 1, 2) = ws1.Range("C" & r.Row).Value .List(.ListCount - 1, 3) = ws1.Range("D" & r.Row).Value .List(.ListCount - 1, 4) = ws1.Range("E" & r.Row).Value .List(.ListCount - 1, 5) = ws1.Range("F" & r.Row).Value .List(.ListCount - 1, 6) = ws1.Range("G" & r.Row).Value .List(.ListCount - 1, 7) = ws1.Range("H" & r.Row).Value .List(.ListCount - 1, 8) = ws1.Range("I" & r.Row).Value .List(.ListCount - 1, 9) = ws1.Range("J" & r.Row).Value .List(.ListCount - 1, 10) = ws1.Range("K" & r.Row).Value End If Next i End With Call HabilitaControles End Sub 4º E em um modulo, cole a função FindAll: (*esta função é que faz a pesquisa em toda as celulas na aba) Function FindAll(what, Optional SearchWhat As Variant, _ Optional LookIn, _ Optional LookAt, _ Optional SearchOrder, _ Optional SearchDirection As XlSearchDirection = xlNext, _ Optional MatchCase As Boolean = False, _ Optional MatchByte, _ Optional SearchFormat) As Range Dim aRng As Range If IsMissing(SearchWhat) Then On Error Resume Next Set aRng = ActiveSheet.UsedRange On Error GoTo 0 ElseIf TypeOf SearchWhat Is Range Then If SearchWhat.Cells.Count = 1 Then Set aRng = SearchWhat.Parent.UsedRange Else Set aRng = SearchWhat End If ElseIf TypeOf SearchWhat Is Worksheet Then Set aRng = SearchWhat.UsedRange Else Exit Function '***** End If If aRng Is Nothing Then Exit Function '***** Dim FirstCell As Range, CurrCell As Range With aRng.Areas(aRng.Areas.Count) Set FirstCell = .Cells(.Cells.Count) End With Set FirstCell = aRng.Find(what:=what, After:=FirstCell, _ LookIn:=LookIn, LookAt:=LookAt, _ SearchDirection:=SearchDirection, MatchCase:=MatchCase, _ MatchByte:=MatchByte, SearchFormat:=SearchFormat) If FirstCell Is Nothing Then Exit Function '***** Set CurrCell = FirstCell Set FindAll = CurrCell Do Set FindAll = Application.Union(FindAll, CurrCell) Set CurrCell = aRng.Find(what:=what, After:=CurrCell, _ LookIn:=LookIn, LookAt:=LookAt, _ SearchDirection:=SearchDirection, MatchCase:=MatchCase, _ MatchByte:=MatchByte, SearchFormat:=SearchFormat) Loop Until CurrCell.Address = FirstCell.Address End Function Até é possível, mas já é mais complicado para atender esta demanda, pois tem que criar muitas condições e fazer tipo uma pesquisa em um banco de palavras para comparar o que foi digitado e fazer a correção.

@Rafael Damian para que possam entender melhor o que você precisa e analisar o formato do seu Documento, poste seu arquivo ou um modelo bem próximo.

Não sei se entendi bem o que precisa, de qualquer forma veja se é isso: Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' Clear the color of all the cells Cells.Interior.ColorIndex = 0 If IsEmpty(Target) Or Target.Cells.Count > 1 Then Exit Sub Application.ScreenUpdating = False With ActiveCell ' Highlight the row and column that contain the active cell, within the current region Range(Cells(.Row, .CurrentRegion.Column), Cells(.Row, .CurrentRegion.Columns.Count + _ .CurrentRegion.Column - 1)).Interior.ColorIndex = ActiveSheet.Tab.ColorIndex End With Application.ScreenUpdating = True End Sub

Neste modelo você pode pesquisar em qualquer campo, mas tem que digitar o termo no campo correto e com essas alterações abaixo no botão de pesquisa: Substitua o código do botão "Pesquisar Registro" por este: Private Sub btnPesquisar_Click() Dim lngRow As Long Dim X As Long, y As Long: y = 0 Dim o que As String If Me.txtID.Text <> "" Then X = 1: o que = Me.txtID.Text: GoTo Px If Me.txtSolicitante.Text <> "" Then X = 3: o que = Me.txtSolicitante.Text: GoTo Px If Me.txtREQ.Text <> "" Then X = 4: o que = Me.txtREQ.Text: GoTo Px If Me.cboComplexidade.Text <> "" Then X = 5: o que = Me.cboComplexidade.Text: GoTo Px If Me.cboTI.Text <> "" Then X = 7: o que = Me.cboTI.Text: GoTo Px If Me.txtResponsavel.Text <> "" Then X = 9: o que = Me.txtResponsavel.Text: GoTo Px If Me.cboStatus.Text <> "" Then X = 10: o que = Me.cboStatus.Text: GoTo Px Px: With ThisWorkbook.Worksheets("Demandas Internas") lngRow = fMatch(o que, .Columns(X)) If lngRow = 0 Then MsgBox "Dados não encontrados!", vbCritical Else Call Multipla_Pesquisa Call HabilitaControles End If End With End Sub * Substitua no codigo o que for "o que" pela letra O + a letra q pois o corretor alterou tudo Conforme a imagem: No botão "Cancelar", pra mim aqui está ok. Já o "fechar" mantenha somente o unload me , pois não existe neste modelo o userform frmMenu, por isso o erro. Private Sub cmdFechar_Click() Unload Me End Sub