Access_2010 vs Windows_7

Buenos dias al grupo:

Estoy creando un libro de excel a partir de una plantilla con el siguiente codigo:

Private Sub BtnPedido_Click()

Dim x As Long, y As Long, Arti As String, UltiFila As Long, LinPedido As Long, NumPre As Long
Dim fila As Integer, columna As Integer, PreMin As Double, PreMax As Double, strFileName As String
Dim xl As Excel.Application

'On Error GoTo Err_Open

Set xl = Excel.Application
xl.Workbooks.Open PatClien() & "\Plantillas\Pedido_ClientePVP2.xlsx"

UltiFila = xl.Sheets(1).UsedRange.Rows.count
fila = 23: columna = 1
LinPedido = (UltiFila - fila) / 2

-------------------------------------------------------------------

Aqui el resto del codigo para terminar

------------------------------------------------------------------

With xl.FileDialog(msoFileDialogSaveAs)
     .ButtonName = "Guardar"
     .InitialFileName = PatClien() & "\Pedido_" & Replace(Nz(Me.NameColec, "Catálogo"), Space(1), "_")
     .Title = "Guardar Libro Excel como"
        If .Show = -1 Then
            strFileName = .SelectedItems(1)
        Else
            MsgBox "Operación cancelada.", vbInformation, "PEDIDOS"
            xl.ActiveWorkbook.Close False
            GoTo Exit_ErrOpen
        End If
    End With

xl.ActiveWorkbook.SaveAs strFileName
xl.ActiveWorkbook.Close True
MsgBox "Hoja de Pedido creada.", vbInformation, "PEDIDOS"
Exit_ErrOpen:
xl.Workbooks.Close
xl.Application.Quit
Set xl = Nothing
Exit Sub
Err_Open:
If Err = 462 Then
   MsgBox "Error " & Err & vbCrLf & Err.description & vbCrLf & "Vuelve a intentarlo a continuación.", vbInformation, "PEDIDOS"
Else
    MsgBox "Error " & Err & vbCrLf & Err.description
End If
End Sub

El problema, al menos en mi ordenador porque en otros no lo he detectado, es que cuando ejecuto por segunda vez consecutiva el procedimiento, sin salirme del formulario, me salta el error 462 en tiempo de ejecucción. "El equipo servidor remoto no existe o no está disponible".

Y esto se repite de forma continuada cuando habilito el control de errores. Si por el contrario lo deshabilito, funciona una Si y otra NO correlativamente.

¿Como puedo controlarlo?

Saludos para todos.

Hola Main,

En que linea te salta el error???

Hola Jilo:

Pongo todo el codigo para que se vea completo

Private Sub BtnPedido_Click()
Dim x As Long, y As Long, Arti As String, UltiFila As Long, LinPedido As Long, NumPre As Long
Dim fila As Integer, columna As Integer, PreMin As Double, PreMax As Double, strFileName
Dim xl As Excel.Application
If Nz(Me.PatFoto, "") = "" Then MsgBox "Seleciona una carpeta con el catálogo.", vbInformation, "PEDIDOS": Exit Sub

'On Error GoTo Err_Open
    ' Creo una instancia de Excel

'Set xl =  Excel.Application  Aqui es donde saltaba primero el error y lo cambie por la siguiente linea

Set xl = New Excel.Application
xl.Workbooks.Open PatClien() & "\Plantillas\Pedido_ClientePVP2.xlsx"
xl.ActiveSheet.UnProtect "******"
UltiFila = xl.Sheets(1).UsedRange.Rows.count
fila = 23: columna = 1
LinPedido = (UltiFila - fila) / 2
If LinPedido < Me.LstArti.ListCount Then
    If MsgBox("La plantila solo dispone de " & LinPedido & " Lineas de Pedido." & vbCrLf & "¿Deseas continuar.?", 292, "Pedidos") = vbNo Then
        xl.ActiveWorkbook.Close False
        GoTo Exit_ErrOpen
    End If
End If
For x = 0 To Me.LstArti.ListCount - 1
    If LinPedido = 0 Then Exit For
    Arti = FicheroLogo(Nz(Me.PatFoto, PatClien()), Me.LstArti.ItemData(x))
    If Arti <> "No Existe." Then
       xl.Cells(fila, columna).Activate ' .Select
       Me.LstArti = Me.LstArti.ItemData(x)
       LstArti_AfterUpdate
       xl.ActiveSheet.Shapes.AddPicture Me.PatFoto & "\" & Arti, False, True, xl.ActiveCell.Left, xl.ActiveCell.Top, xl.ActiveCell.Width, xl.ActiveCell.Height * 2
       xl.Range("A20") = Me.NameColec
       xl.Cells(fila, columna + 1) = Me.LstArti.Column(2): xl.Cells(fila, columna + 2) = Me.LstArti: xl.Cells(fila, columna + 3) = Me.LstArti.Column(3)
       If Me.LstPVPArti.ListCount = 1 Then
            xl.DisplayAlerts = False
            xl.Cells(fila, 33) = Me.LstPVPArti.Column(1)
            For y = 31 To 34 'Combino  las celdas de las columnas de los artículos que tienen un solo precio
                xl.Range(Cells(fila, y), Cells(fila + 1, y)).Merge  'Ahora me salta aqui
            Next y
            xl.DisplayAlerts = True
            For y = 0 To Me.LstTalla.ListCount - 1 'Combino  las celdas de las columnas de tallas de los artículos que tienen un solo precio
                xl.Range(Cells(fila, Me.LstTalla.Column(1, y) - 11), Cells(fila + 1, Me.LstTalla.Column(1, y) - 11)).Merge
                xl.Range(Cells(fila, Me.LstTalla.Column(1, y) - 11), Cells(fila + 1, Me.LstTalla.Column(1, y) - 11)).Interior.Color = RGB(255, 255, 255)
                xl.Range(Cells(fila, Me.LstTalla.Column(1, y) - 11), Cells(fila + 1, Me.LstTalla.Column(1, y) - 11)).BorderAround LineStyle:=xlContinuous, ColorIndex:=0 ', Weight:=xlThick
            Next y
       Else
            PreMin = DMin("PVP", "ArticulosEmpresa", "ReferArti='" & Me.LstArti & "'")
            PreMax = DMax("PVP", "ArticulosEmpresa", "ReferArti='" & Me.LstArti & "'")
            xl.Cells(fila, 33) = CDbl(PreMin)
            xl.Cells(fila + 1, 33) = CDbl(PreMax)
            For y = 0 To Me.LstTalla.ListCount - 1 'Resalto  las celdas de las columnas de tallas de los artículos que tienen dos precios
                If Me.LstTalla.Column(2, y) = PreMin Then
                    xl.Cells(fila, Me.LstTalla.Column(1, y) - 11).BorderAround LineStyle:=1, Weight:=xlThin, ColorIndex:=0
                    xl.Cells(fila, Me.LstTalla.Column(1, y) - 11).Interior.Color = RGB(255, 255, 255)
                Else
                    xl.Cells(fila + 1, Me.LstTalla.Column(1, y) - 11).BorderAround LineStyle:=1, Weight:=xlThin, Color:=RGB(0, 0, 0)
                    xl.Cells(fila + 1, Me.LstTalla.Column(1, y) - 11).Interior.Color = RGB(255, 255, 255)
                End If
            Next y
       End If
       NumPre = Me.LstPVPArti.ListCount
       fila = fila + 2
       LinPedido = LinPedido - 1
    End If
Next x
    strFileName = xl.GetSaveAsFilename( _
    InitialFileName:=PatClien() & "\Pedido_" & Replace(Nz(Me.NameColec, "Catálogo"), Space(1), "_"), _
    fileFilter:="Archivos Excel (*.xlsx), *.xlsx")
    If strFileName = False Then
       MsgBox "Operación cancelada.", vbInformation, "PEDIDOS"
       xl.ActiveWorkbook.Close False
       GoTo Exit_ErrOpen
    End If
'xl.ActiveSheet.ScrollArea = "E2:AD126"
'xl.Cells(23, 2).Locked = True
xl.ActiveSheet.Protect "******"
xl.ActiveWorkbook.SaveAs strFileName
xl.ActiveWorkbook.Close True
MsgBox "Hoja de Pedido creada.", vbInformation, "PEDIDOS"
Exit_ErrOpen:
xl.Workbooks.Close
xl.Application.Quit
Set xl = Nothing

exit sub

Err_Open:
If Err = 462 Then
   MsgBox "Error " & Err & vbCrLf & Err.description & vbCrLf & "Vuelve a intentarlo a continuación.", vbInformation, "PEDIDOS"
   Set xl = New Excel.Application
   Resume Exit_ErrOpen
ElseIf Err = 1004 Then
   xl.ActiveWorkbook.Close False
   Resume Exit_ErrOpen
Else
    MsgBox "Error " & Err & vbCrLf & Err.description
End If
End Sub

Es como si tuviera abierta la aplicación de excel y no me lacerrara al  terminar el procedimiento.

A ver si esto te sirve:

- https://support.microsoft.com/es-es/help/189618/you-may-receive-the-run-time-error-2147023174-800706ba-error-message-o

Que en tu caso, puede ser porque Cells no es de Access y no está referenciado al objeto Excel que has abierto:

xl.Range(Cells(fila, y), Cells(fila + 1, y)).Merge

Hola:

Reuelto, efectivamente cells no es de Access y no está referenciado al objeto Excel que tengo abierto:

xl.Range(xl.Cells(fila, y), xl.Cells(fila + 1, y)).Merge
y asunto resuelto.
Muchas gracias pitxicu
Se puede cerrar el tema.
Saludos para todos.