Pesquisar na Comunidade

Olá, pessoal queria saber qual comando posso usar para obter o caminho do arquivo coreldraw que esta ativo no momento que executo a macro.Tente usar o comando "ThisWorkbook.Path" mas ele não funciona.

olá pessoal, sei um pouco de VBA e queria fazer uma macro que quando executada dentro de manual ele pegue uma imagem que esta na mesma pasta do arquivo CorelDraw, posicione no espaço e dimensione já com as medidas, depois disso ele apague a imagem existente e coloque a nova imagem na mesmo posição da imagem antiga dentro da camada. Estou usando o comando ActiveWorkbook.Path para pegar o caminho na rede onde esta o arquivo CorelDraw mas parece que ele não reconhece e esta dando o segui erro: Objeto requerido (Erro 424). Poderia me ajudar? OBS: código ainda não esta completo! Código: Sub trocar_imagens() ' Recorded 03/03/2023 Dim impopt As StructImportOptions Set impopt = CreateStructImportOptions With impopt .Mode = cdrImportFull .MaintainLayers = True With .ColorConversionOptions .SourceColorProfileList = "sRGB IEC61966-2.1,U.S. Web Coated (SWOP) v2,Dot Gain 20%" .TargetColorProfileList = "sRGB IEC61966-2.1,U.S. Web Coated (SWOP) v2,Dot Gain 20%" End With End With 'Dim pasta As ImportFilter 'Set pasta = ActiveWorkbook.Path & "\" & "\IMAGENS\FIG. A1.JPG" 'pasta.Finish 'pasta = A 'MsgBox pasta Dim impflt As ImportFilter Set impflt = ActiveDocument.Pages(24).Layers("Camada 1").ImportEx(ActiveWorkbook.Path & "\IMAGENS\FIG. A1.JPG", cdrJPEG, impopt) impflt.Finish Dim s1 As Shape Set s1 = ActiveShape ActiveDocument.Pages(24).Layers("Camada 1").Shapes(1).Move -0.198937, -0.752177 ActiveDocument.ReferencePoint = cdrCenter ActiveDocument.Pages(24).Layers("Camada 1").Shapes(1).SetSize 6.889764, 4.774157 ActiveDocument.Pages(24).Layers("Camada 1").Shapes(1).SetPosition 4.133858, 5.11811 ActiveDocument.Pages(24).Layers("Camada 1").Shapes(3).Delete ActiveDocument.Pages(24).Layers("Camada 1").Shapes(2).OrderBackOf ActiveDocument.Pages(24).Layers("Camada 1").Shapes(1) ActiveDocument.Pages(25).Activate End Sub

Olá pessoal, tudo bem? Tenho uma planilha com macros para tratamento de dados e está habilitada para macros, porém, acontece um bug que ela simplesmente some com todos os códigos e não deixa salvar a plan. Aparecendo os erros abaixo e quando dou atl+F11 os módulos estão em branco. Já aconteceram 3x com planilhas diferentes. Ela funciona por um período e do Nada acontece esse erro. uso ela todos os dias para atualizar as bases de dados. Alguém já passou por um problema semelhante? Vlw, pessoal.

Bom dia, sei que a função Floor(Day(Minute(ano_inicial / 38) / 2 + 56) & "/5" & "/" & ano_inicial, 7) - 34 funciona na plhanilha mas quando tento executar ela no excel da erro de #VALOR!, não sei resolver. Public Function pascoa(ByVal data_inicial As Date, ByVal data_final As Date) As Date ano_inicial = Year(data_inicial) pascoa = WorksheetFunction.Floor(Day(Minute(ano_inicial / 38) / 2 + 56) & "/5" & "/" & ano_inicial, 7) - 34 End Function

Bom dia, estou tentando fazer uma function que pega como parâmetro duas datas e retorna os dias uteis desse período, entretanto não consigo entender o que estou fazendo de errado 'retorna os dias uteis Public Function DiasUteis(ByVal data_inicial As Date, ByVal data_final As Date) As Integer Ano_inicial = Year(data_inicial) Ano_final = Year(data_final) Aux = 0 Corridos = WorksheetFunction.NetworkDays(data_inicial, data_final) Feriados = 0 While Aux <= Ano_final If Aux = 0 Then Aux = Ano_inicial End If pascoa = WorksheetFunction.Floor(Day(Minute(Aux / 38) / 2 + 56) & "/5" & "/" & Aux, 7) - 34 pascoa = CDate(pascoa) Carnaval1 = CDate(pascoa - 48) Calnaval2 = CDate(canaval1 + 1) Paixao = CDate(pascoa - 2) Corpo = CDate(pascoa + 60) tiradentes = WorksheetFunction.Date(Aux, 4, 21) confraternizacao = WorksheetFunction.Date(Aux, 1, 1) Trabalho = WorksheetFunction.Date(Aux, 5, 1) Independencia = WorksheetFunction.Date(Aux, 9, 7) Senhora = WorksheetFunction.Date(Aux, 10, 12) Finados = WorksheetFunction.Date(Aux, 11, 2) proclamacao = WorksheetFunction.Date(Aux, 11, 15) Natal = WorksheetFunction.Date(Aux, 12, 25) If pascoa > data_inicial Then If pascoa < data_final Then Feriados = Feriados + 1 End If End If If pascoa > data_inicial Then If pascoa < data_final Then Feriados = Feriados + 1 End If End If If Carnaval1 > data_inicial Then If Carnaval1 < data_final Then Feriados = Feriados + 1 End If End If If Carnaval2 > data_inicial Then If Carnaval2 < data_final Then Feriados = Feriados + 1 End If End If If Paixao > data_inicial Then If Paixao < data_final Then Feriados = Feriados + 1 End If End If If Corpo > data_inicial Then If Corpo < data_final Then Feriados = Feriados + 1 End If End If If tiradentes > data_inicial Then If tiradentes < data_final Then Feriados = Feriados + 1 End If End If If confraternizacao > data_inicial Then If confraternizacao < data_final Then Feriados = Feriados + 1 End If End If If Trabalho > data_inicial Then If Trabalho < data_final Then Feriados = Feriados + 1 End If End If If Independencia > data_inicial Then If Independencia < data_final Then Feriados = Feriados + 1 End If End If If Senhora > data_inicial Then If Senhora < data_final Then Feriados = Feriados + 1 End If End If If Natal > data_inicial Then If Natal < data_final Then Feriados = Feriados + 1 End If End If If Finados > data_inicial Then If Finados < data_final Then Feriados = Feriados + 1 End If End If If proclamacao > data_inicial Then If proclamacao < data_final Then Feriados = Feriados + 1 End If End If Aux = Aux + 1 Wend Corridos = Corridos - Feriados DiasUteis = Corridos End Function

Olá! Eu tenho um programa que sempre funcionou muitíssimo bem e esse mês ele não quis funcionar... O erro que dá é : .CurrentPage = _ "APAC" Por Favor me ajudem!!! Public strEvolMes As String Public strEvolAno As String Public strEvolYTD As String Public strEvolMat As String Public strCam As String Sub X() PROCESSO "NRC" End Sub Sub AbreArquivo() ' ActiveWorkbook.Path Workbooks.Open Filename:=ActiveWorkbook.Path & "\TEMPLATE_GD.xlsx" End Sub Sub CONEXAO2(Planilha As String, filtros As Integer, Banco As String, TABLE As String, FILTRO_GD As String) ' ' Macro1 Macro 'Provider=SQLOLEDB.1;Password=pmk-01;Persist Security Info=True;User ID=sa;Initial Catalog=CLT_ABBOTT;Data Source=s-cupbr21 '"Packet Size=4096;Use Encryption for Data=True;Tag with column collation when possible=False;Initial Catalog=" & Banco & ""), Array("""" & Banco & """.""dbo"".""" & TABLE & """"), 3 Dim SQL As String 'SQL = "SELECT top 10 * FROM `" & Replace(UCase(ArquivoMDB), ".MDB", "") & "`.TEMPLATE" SQL = "SELECT * FROM " & TABLE & " WHERE REP = '" & FILTRO_GD & "'" ' With ActiveWorkbook.PivotCaches.Add(SourceType:=xlExternal) ' .Connection = _ ' "OLEDB;Provider=SQLOLEDB.1;Persist Security Info=True;Password= 101013; User ID=sa;Data Source=.;Use Procedure for Prepare=1;Auto Translate=True; Initial Catalog=" & Banco & "" ' .CommandType = xlCmdSql ' .CommandText = Array(SQL) ' .CreatePivotTable TableDestination:="R" & 7 + filtros & "C2", TableName:=Planilha, DefaultVersion:=xlPivotTableVersion12 ' End With ActiveWorkbook.Connections.Add Banco & TABLE, "" _ , Array("OLEDB;Provider=SQLOLEDB.1;Persist Security Info=True;Password=pmk-01; User ID=sa;Data Source=192.1.3.52;Use Procedure for Prepare=1;Auto Translate=True; Initial Catalog=" & Banco & ""), _ Array(SQL), xlCmdSql ' ActiveWorkbook.PivotCaches.Create(SourceType:=xlExternal, SourceData:=ActiveWorkbook.Connections(Banco & TABLE), Version _ ' :=xlPivotTableVersion12).CreatePivotTable TableDestination:="R" & 7 + filtros & "C2", TableName:=Planilha, DefaultVersion:=xlPivotTableVersion12 ActiveWorkbook.PivotCaches.Create(SourceType:=xlExternal, SourceData:=ActiveWorkbook.Connections(Banco & TABLE), Version _ :=xlPivotTableVersion12).CreatePivotTable TableDestination:="R" & 7 + filtros & "C2", TableName:=Planilha, DefaultVersion:=xlPivotTableVersion12 With ActiveSheet.PivotTables(1) .DisplayErrorString = True .ErrorString = "0" .RowGrand = False .InGridDropZones = True .ColumnGrand = False .ShowValuesRow = False .InGridDropZones = True End With End Sub Sub MontaTabela(tabelas As String, filtros As String, Valores As String, linhas As String, coluna As String) Dim TABELA As String Dim tabelaMatriz As String Dim Celula As String Dim Nome As String Dim Stilo As String Dim Size As Integer Dim CorFonte As Integer Dim CorCelula As Integer Dim avarSplit1 As Variant Dim avarSplit2 As Variant Dim avarSplit3 As Variant Dim TabelaSplit As Variant Dim FiltroSplit As Variant Dim LinhaSplit As Variant Dim ColunaSplit As Variant Dim ValoresSplit As Variant Dim tabelaAnterior As String Dim strGDGA As String Dim strBanco As String Dim strTabela As String Dim conn As ADODB.Connection Dim intIndex As Integer Dim i As Integer Set conn = New ADODB.Connection With conn .ConnectionString = "Provider=SQLOLEDB.1;Password=pmk-01;Persist Security Info=True;User ID=sa;Initial Catalog=CLT_FERRING;Data Source=192.1.3.52" .CommandTimeout = 0 .Open End With Set RS_REP = CreateObject("ADODB.Recordset") Set comm1 = CreateObject("ADODB.Command") With comm1 .CommandText = "UP_LISTA_GD" .CommandType = 4 .ActiveConnection = conn .CommandTimeout = 0 Set RS_REP = .Execute End With Do While Not RS_REP.EOF strGDGA = RS_REP(0) Call AbreArquivo tabelaAnterior = "" TabelaSplit = Split(tabelas, "|") FiltroSplit = Split(filtros, "|") ColunaSplit = Split(coluna, "|") LinhaSplit = Split(linhas, "|") ValoresSplit = Split(Valores, "|") intIndex = 0 For i = LBound(TabelaSplit) To UBound(TabelaSplit) avarSplit1 = Split(TabelaSplit(i), "#") TABELA = avarSplit1(0) If tabelaAnterior <> TABELA Then ActiveWorkbook.Sheets(TABELA).Select If intIndex = 0 Then tabelaMatriz = TABELA strBanco = avarSplit1(3) strTabela = avarSplit1(4) Rows("9:40").Select Selection.Delete Shift:=xlUp Call CONEXAO2(TABELA, avarSplit1(1) + 2, strBanco, strTabela, strGDGA) Else ActiveWorkbook.Sheets(tabelaMatriz).Rows("9:40").Copy ActiveWorkbook.Sheets(TABELA).Range("A9").Select ActiveSheet.Paste End If 'intIndex = 1 tabelaAnterior = TABELA End If Next For i = LBound(TabelaSplit) To UBound(TabelaSplit) avarSplit2 = Split(TabelaSplit(i), "#") TABELA = avarSplit2(0) If tabelaAnterior <> TABELA Then intIndex = 0 Range("a1").Select ActiveWorkbook.Sheets(TABELA).Select 'Call CONEXAO(tabela, avarSplit2(1) + 2) tabelaAnterior = TABELA End If If ColunaSplit(i) <> "" Then avarSplit2 = Split(ColunaSplit(i), "#") If avarSplit2(0) <> "" Then 'With ActiveSheet.PivotTables(tabela).PivotFields(avarSplit2(0)) With ActiveSheet.PivotTables(1).PivotFields(avarSplit2(0)) .Orientation = xlColumnField .Position = 1 End With ActiveSheet.PivotTables(1).InGridDropZones = False ActiveSheet.PivotTables(1).InGridDropZones = True Celula = avarSplit2(0) Nome = avarSplit2(1) Stilo = avarSplit2(2) Size = avarSplit2(3) CorFonte = avarSplit2(4) CorCelula = avarSplit2(5) FORMATO Celula, Nome, Stilo, Size, CorFonte, CorCelula End If End If If FiltroSplit(i) <> "" Then avarSplit2 = Split(FiltroSplit(i), "#") If avarSplit2(0) <> "" Then 'With ActiveSheet.PivotTables(tabela).PivotFields(avarSplit2(0)) With ActiveSheet.PivotTables(1).PivotFields(avarSplit2(0)) .Orientation = xlPageField .Position = 1 If avarSplit2(0) = "METRICA" Then .CurrentPage = _ "APAC" 'ElseIf avarSplit2(0) = "MOLECULA" And TABELA <> "REPORT_CNES" Then ' .CurrentPage = _ ' " TOTAL MERCADO" End If End With ActiveSheet.PivotTables(1).InGridDropZones = False ActiveSheet.PivotTables(1).InGridDropZones = True Celula = avarSplit2(0) Nome = avarSplit2(1) Stilo = avarSplit2(2) Size = avarSplit2(3) CorFonte = avarSplit2(4) CorCelula = avarSplit2(5) FORMATO Celula, Nome, Stilo, Size, CorFonte, CorCelula End If End If If LinhaSplit(i) <> "" Then avarSplit2 = Split(LinhaSplit(i), "#") If avarSplit2(0) <> "" Then 'With ActiveSheet.PivotTables(tabela).PivotFields(avarSplit2(0)) With ActiveSheet.PivotTables(1).PivotFields(avarSplit2(0)) .Orientation = xlRowField .Position = 1 End With ActiveSheet.PivotTables(1).InGridDropZones = False ActiveSheet.PivotTables(1).InGridDropZones = True Celula = avarSplit2(0) Nome = avarSplit2(1) Stilo = avarSplit2(2) Size = avarSplit2(3) CorFonte = avarSplit2(4) CorCelula = avarSplit2(5) FORMATO Celula, Nome, Stilo, Size, CorFonte, CorCelula End If End If If ValoresSplit(i) <> "" Then avarSplit2 = Split(ValoresSplit(i), "#") If avarSplit2(0) <> "" Then 'ActiveSheet.PivotTables(tabela).AddDataField ActiveSheet.PivotTables(tabela).PivotFields(avarSplit2(0)), " " & avarSplit2(0), xlSum ActiveSheet.PivotTables(1).AddDataField ActiveSheet.PivotTables(1).PivotFields(avarSplit2(0)), " " & avarSplit2(0), xlSum 'ActiveSheet.PivotTables(1).AddDataField ActiveSheet.PivotTables(1).PivotFields("Evol Mês"), " Evol Mês", xlSum If avarSplit2(6) = 1 Then 'With ActiveSheet.PivotTables(tabela).PivotFields(" " & avarSplit2(0)) With ActiveSheet.PivotTables(1).PivotFields(" " & avarSplit2(0)) .Calculation = xlPercentOfColumn .NumberFormat = "0.00%" End With ElseIf avarSplit2(6) = 0 Then 'With ActiveSheet.PivotTables(tabela).PivotFields(" " & avarSplit2(0)) With ActiveSheet.PivotTables(1).PivotFields(" " & avarSplit2(0)) .NumberFormat = "#,##0" End With ElseIf avarSplit2(6) = 2 Then 'With ActiveSheet.PivotTables(tabela).PivotFields(" " & avarSplit2(0)) With ActiveSheet.PivotTables(1).PivotFields(" " & avarSplit2(0)) .NumberFormat = "0.00%" End With ElseIf avarSplit2(6) = 3 Then 'With ActiveSheet.PivotTables(tabela).PivotFields(" " & avarSplit2(0)) With ActiveSheet.PivotTables(1).PivotFields(" " & avarSplit2(0)) .Calculation = xlPercentOfRow .NumberFormat = "0.00%" End With End If If intIndex = 1 Then 'With ActiveSheet.PivotTables(tabela).DataPivotField With ActiveSheet.PivotTables(1).DataPivotField .Orientation = xlColumnField .Position = 1 End With ActiveSheet.PivotTables(1).InGridDropZones = False ActiveSheet.PivotTables(1).InGridDropZones = True avarSplit3 = Split(ValoresSplit(i - 1), "#") Celula = avarSplit3(0) Nome = avarSplit2(1) Stilo = avarSplit2(2) Size = avarSplit2(3) CorFonte = avarSplit2(4) CorCelula = avarSplit2(5) FORMATO Celula, Nome, Stilo, Size, CorFonte, CorCelula ' FORMATO avarSplit3(0), avarSplit2(1), avarSplit2(2), avarSplit2(3), avarSplit2(4), avarSplit2(5) 'ActiveSheet.PivotTables(1).CalculatedFields("Evol Mês").StandardFormula = strEvolMes End If Celula = avarSplit2(0) Nome = avarSplit2(1) Stilo = avarSplit2(2) Size = avarSplit2(3) CorFonte = avarSplit2(4) CorCelula = avarSplit2(5) FORMATO Celula, Nome, Stilo, Size, CorFonte, CorCelula ' If avarSplit(8) <> "" Then ' With ActiveSheet.PivotTables(1).PivotFields(avarSplit(8)) ' .Orientation = xlColumnField ' .Position = 1 ' End With ' End If End If End If intIndex = intIndex + 1 Next Sheets("Capa").Select Range("A1").Select If strGDGA <> "" Then ActiveWorkbook.SaveAs Filename:=strCam & "\" & strGDGA & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False ActiveWindow.Close RS_REP.MOVENEXT Loop End Sub Sub FORMATO(Celula As String, Nome As String, Stilo As String, Size As Integer, CorFonte As Integer, CorCelula As Integer) On Error GoTo ERROS Cells.Find(What:=Celula, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Select With Selection.Font .Name = Nome .FontStyle = Stilo .Size = Size .ColorIndex = CorFonte .ColumnGrand = False .ShowValuesRow = False .InGridDropZones = True End With With Selection.Interior .ColorIndex = CorCelula .Pattern = xlSolid .PatternColorIndex = xlAutomatic End With Exit Sub ERROS: If Err.Number = 91 Then Exit Sub Resume Next End Sub Sub PROCESSO(SHEET As String) Dim TABELA As String Dim Banco As String Dim tabelaAnterior As String Dim NomeSheet As String Dim valor As String Dim avarSplit As Variant Dim TabelaSplit As Variant Dim filtros As String Dim LINHA As String Dim coluna As String Dim Valores As String Dim intIndex As Integer strEvolMes = Range("evolmes").Value strEvolAno = Range("EvolAno").Value strEvolYTD = Range("EvolYTD").Value strEvolMat = Range("EvolMat").Value strCam = Range("STRCAMINHO").Value Dim i As Integer For i = 2 To Sheets(SHEET).Range("A1").End(xlDown).Row If Sheets(SHEET).Range("A" & i).Value <> "" Then TABELA = TABELA & "|" & Sheets(SHEET).Range("A" & i).Value & "#" & Sheets(SHEET).Range("F" & i).Value & "##" & Sheets(SHEET).Range("j" & i).Value & "#" & Sheets(SHEET).Range("k" & i).Value 'If Ini.Range("B" & i).Value <> "" Then filtros = filtros & "|" & Trim(Sheets(SHEET).Range("B" & i).Value) & "#" & Sheets(SHEET).Range("B" & i).Font.Name & "#" & Sheets(SHEET).Range("B" & i).Font.FontStyle & "#" & Sheets(SHEET).Range("B" & i).Font.Size & "#" & Sheets(SHEET).Range("B" & i).Font.ColorIndex & "#" & Sheets(SHEET).Range("B" & i).Interior.ColorIndex 'If Ini.Range("C" & i).Value <> "" Then LINHA = LINHA & "|" & Trim(Sheets(SHEET).Range("C" & i).Value) & "#" & Sheets(SHEET).Range("c" & i).Font.Name & "#" & Sheets(SHEET).Range("c" & i).Font.FontStyle & "#" & Sheets(SHEET).Range("c" & i).Font.Size & "#" & Sheets(SHEET).Range("c" & i).Font.ColorIndex & "#" & Sheets(SHEET).Range("c" & i).Interior.ColorIndex 'If Ini.Range("D" & i).Value <> "" Then Valores = Valores & "|" & Trim(Sheets(SHEET).Range("D" & i).Value) & "#" & Sheets(SHEET).Range("d" & i).Font.Name & "#" & Sheets(SHEET).Range("d" & i).Font.FontStyle & "#" & Sheets(SHEET).Range("d" & i).Font.Size & "#" & Sheets(SHEET).Range("d" & i).Font.ColorIndex & "#" & Sheets(SHEET).Range("d" & i).Interior.ColorIndex & "#" & Sheets(SHEET).Range("E" & i).Value & "#" & Sheets(SHEET).Range("G" & i).Value & "#" & Sheets(SHEET).Range("H" & i).Value coluna = coluna & "|" & Trim(Sheets(SHEET).Range("I" & i).Value) & "#" & Sheets(SHEET).Range("I" & i).Font.Name & "#" & Sheets(SHEET).Range("I" & i).Font.FontStyle & "#" & Sheets(SHEET).Range("I" & i).Font.Size & "#" & Sheets(SHEET).Range("I" & i).Font.ColorIndex & "#" & Sheets(SHEET).Range("I" & i).Interior.ColorIndex Next TABELA = Right(TABELA, Len(TABELA) - 1) coluna = Right(coluna, Len(coluna) - 1) LINHA = Right(LINHA, Len(LINHA) - 1) Valores = Right(Valores, Len(Valores) - 1) filtros = Right(filtros, Len(filtros) - 1) Call MontaTabela(TABELA, filtros, Valores, LINHA, coluna) End Sub