Ajuda com o Excel por favor

[Daniela Stone]

Tenho uma planilha usada para imprimir automaticamente dezenas de formularios diferentes que estão contidas em uma pasta.

Ela funciona normalmente quando a pasta que contem a planilha e os formularios esta no drive C, porém se a pasta for colocada na intranet, ao mandar imprimir, da erro! Sai uma mensagem com path do arquivo, dizendo que o arquivo nao foi encontrado! Como posso resolver isto?

A planilha foi feita no excel 2003 e usa codigo VBA, atualmente uso o excel 2010.Ela funcionava normalmente ate pouco tempo atras...porém o drive da intranet foi mudado ...a partir dai as coisas nao funcionam mais como antes.

O codigo esta aqui... mas se funcionava antes , nao deve estar errado!

Sub Imprimir()

Dim i As Integer, j As Integer

Dim v As Variant, xMC As String

Dim rng As Range

Set rng = Range("G4", Range("G4").End(xlDown))

v = UBound(Application.Transpose(Application _

.Transpose(rng)), 1)

For j = 1 To 5 '' Loop de prioridades de impressao

'' '' 1=Shukka/Kit; 2=Mecanica; 3=Producao; 4=Bimestral; 5=Anual

For i = 4 To v + 3

If Cells(i, 5) <> "" And Range("G" & i).Value <> 0 Then xMC = Cells(i, 5).Value

If Cells(i, 5) = Empty Then Exit For

If Format(Range("E2"), "M") Mod 2 <> 0 And j = 4 Then Exit For '' Imprime bimestrais

If Range("X2").Value <> True And j = 5 Then Exit For '' Imprime anuais

If Range("G" & i).Value = "Y" And Range("G" & i).Value <> "" And _

Range("S" & i) = j And Range("F" & i) >= 1 Then

ExcelPrinter Range("T" & i), Range("U" & i), Range("F" & i), Range("E2").Value, _

xMC, Range("V" & i), Range("W" & i)

End If

Next i

Next j

End Sub

Sub Editar()

Dim i As Integer

Dim v As Variant, xMC As String

Dim rng As Range

Set rng = Range("G4", Range("G4").End(xlDown))

v = UBound(Application.Transpose(Application _

.Transpose(rng)), 1)

For i = 4 To v + 3

If Range("G" & i).Value = "Y" And Range("G" & i).Value <> "" Then ExcelEdit Range("T" & i), Range("U" & i)

Next i

End Sub

Public Function ExcelPrinter(ByVal xLink As String, _

ByVal xSheet As String, _

ByVal xCopy As Integer, _

ByVal xCalendar As Date, _

Optional ByVal xMC As String, _

Optional ByVal xTexto1 As String, _

Optional ByVal xTexto2 As String)

Dim xExcel As Object

Dim xMes As Integer, xAno As Integer, i As Integer

Set xExcel = CreateObject("Excel.Application")

xAno = Format(xCalendar, "YYYY")

xMes = Format(xCalendar, "M")

With xExcel

.Workbooks.Open ActiveWorkbook.Path & xLink ' O ERRO ACONTECE NESTA LINHA

.Visible = False

.Sheets(xSheet).Select

.Range("CC1").Value = xCalendar

.Range("CC2").Value = xAno

.Range("CC3").Value = xMes

.Range("CC4").Value = xMC

.Range("CC5").Value = "=" & xTexto1

.Range("CC6").Value = xTexto2

For i = 8 To 37 '''' '''' Loop para distribuir os feriados adicionados

.Range("CD" & i - 7).Value = Range("ƒJƒŒƒ“ƒ_[!K" & i).Value

Next i

''' '''' .ActiveSheet.PageSetup.BlackAndWhite = False

.ActiveSheet.PrintOut Copies:=xCopy, Collate:=True

.Application.DisplayAlerts = False

.Application.Quit

End With

Set xExcel = Nothing

End Function

Public Function ExcelEdit(ByVal xLink As String, _

ByVal xSheet As String)

Dim xExcel As Object

Set xExcel = CreateObject("Excel.Application")

With xExcel

.Workbooks.Open ActiveWorkbook.Path & xLink

.Visible = True

.Sheets(xSheet).Select

End With

Set xExcel = Nothing

End Function

Sub Minimo()

With ActiveWindow

.DisplayHeadings = False

.DisplayHorizontalScrollBar = True

.DisplayVerticalScrollBar = True

.DisplayGridlines = False

.DisplayWorkbookTabs = True

End With

Columns("S:X").Hidden = True

End Sub

Sub Normalizar()

Dim barras

On Error Resume Next

For Each barras In Application.CommandBars

barras.Enabled = True

Next

Columns("S:X").Hidden = False

Application.DisplayStatusBar = True

Application.DisplayFormulaBar = True

Application.DisplayFullScreen = False

With ActiveWindow

.DisplayHeadings = True

.DisplayHorizontalScrollBar = True

.DisplayVerticalScrollBar = True

.DisplayWorkbookTabs = True

.DisplayGridlines = True

End With

End Sub

Sub Slide()

Dim barras, nTela, Cont

On Error Resume Next

For Each barras In Application.CommandBars

barras.Enabled = False

Next

Application.DisplayFullScreen = True

ActiveWindow.DisplayHeadings = False

Application.DisplayFormulaBar = False

ActiveWindow.DisplayHorizontalScrollBar = False

ActiveWindow.DisplayVerticalScrollBar = False

ActiveWindow.DisplayWorkbookTabs = False

Application.DisplayStatusBar = False

End Sub

Private Sub Auto_Close()

If Columns("S:W").Hidden = True Then

Else

If MsgBox("Antes de encerrar este aplicativo," & vbCrLf & _

"nao esqueca de ocultar os campos de edicao.", vbOKCancel, "Atencao") = vbCancel Then Exit Sub

End If

End Sub

Desde ja , muito obrigado.

[Márcio Rodrigues]

Olá Daniela Stone

Tente isto logo antes de With xExcel:

SeuArquivo = "K:\Trabalhos\Forum VBA\banco.xlsx" (Insira o caminho do seu arquivo)

If Dir(Arquivo) = vbNullString Then

MsgBox "Arquivo não encontrao", vbCritical, "Abrir arquivo"

Else

With xExcel

.Workbooks.Open SeuArquivo & xLink ' O ERRO ACONTECE NESTA LINHA (mude ActiveWorkbook.Path para SeuArquivo)

.Visible = False

. 'aqui fica tudo igual

.Application.Quit

End With

End If

Veja se é por aí!!!!

Márcio

[Daniela Stone]

Explicando melhor:

Tenho a planilha imprimir.xls , através da qual escolho e mando imprimir de uma só vez dezenas de outras planilhas que estão todas em uma outra pasta.

Tentei seguir suas intruções...mas não deu certo!

[Márcio Rodrigues]

Olá Daniela Stone

Precisamos saber qual tipo de erro ocorre.

Mande o arquivo e informe onde o caminhos onde os arquivos estão armazenados para que possamos simular.

Márcio