Saltar al contenido

Macros que al ejecutarse se detiene y aparece este mensaje: error '-2147023170(800706be) en tiempo de ejecución: error de automarización


Recommended Posts

publicado

Tengo un código VBA para una macros que tiene que colocar los números en forma consecutiva desde la fila 3239 hasta la 3850, pero solo en las columnas A, B, C y D.  Ejemplo: el único rango que tiene números es el A3238:D3238, y son 34, 36, 38, 40. La macro hace que el rango A3239:D3239 aparezcan los números 35, 37, 39, 41, así hasta terminar en la fila 3850 o rango A3850:D3850. Tiene que ejecutarse en una carpeta especifica que tiene más de 70 mil archivos xlsx, de 2000 kb cada uno, y tienen una sola hoja. Lo hace, pero siempre se detiene cuando lo ha hecho en 9250 archivos, mostrando este mensaje: error '-2147023170(800706be) en tiempo de ejecución: error de automatización, Por lo que tengo que sacar los archivos que ya hizo el cambio, y volver a ejecutarla, y así solo lo realiza en 9250 archivos, y no en todos los archivos de la carpeta, Les dejo el código, a ver si me pueden alumbrar en que está fallando. La rapidez es importante y este código lo hace, pero siempre se detiene cuando ha hecho 9250 archivos.  Gracias desde ya.

Sub SumarEnRangoOptimizado()
    Dim folderPath As String
    Dim fileName As String
    Dim excelApp As Object
    Dim wb As Object
    Dim ws As Object
    
    ' Carpeta que contiene los archivos
    folderPath = "D:\Carpeta\"

    ' Deshabilitar actualizaciones de pantalla y cálculos automáticos
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' Crear una instancia de Excel Application
    Set excelApp = CreateObject("Excel.Application")
    excelApp.DisplayAlerts = False ' Desactivar las alertas

    ' Iterar sobre los archivos en la carpeta
    fileName = Dir(folderPath & "\*.xlsx")
    Do While fileName <> ""
        ' Abrir el archivo
        Set wb = excelApp.Workbooks.Open(folderPath & "\" & fileName)
        Set ws = wb.Sheets(1) ' Primera hoja de trabajo
        
        ' Aplicar la fórmula directamente en el rango
        With ws
            .Range("A3239:D3850").Formula = "=A$3238 + (ROW()-3238)"
            .Range("A3239:D3850").Value = .Range("A3239:D3850").Value ' Convertir las fórmulas en valores
        End With
        
        ' Cerrar el archivo sin guardar cambios
        wb.Close SaveChanges:=True
        
        ' Obtener el siguiente archivo en la carpeta
        fileName = Dir
    Loop

    ' Cerrar la instancia de Excel Application
    excelApp.Quit
    Set excelApp = Nothing

    ' Habilitar actualizaciones de pantalla y cálculos automáticos
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "La operación se ha completado en todos los archivos de la carpeta.", vbInformation
End Sub
 

Macros suma abcd.xlsm

publicado

Hola, no tengo experiencia con ese error así que lo busque en Google y me devolvió esto:

El error ‘-2147023170(800706be) generalmente ocurre cuando se intenta acceder a un objeto que ya no está disponible.

Entonces no estoy seguro que lo siguiente funcione pero parece que al ser tantos archivos ocupa demasiada memoria en cada iteración del bucle. Si es así lo que podría recomendarte sería establecer los objetos de excel como wb y ws en el NOTHING después de que ya los uso.

Algo así:

' Cerrar el archivo sin guardar cambios
wb.Close SaveChanges:=True

' Liberar la memoria
Set ws = Nothing
Set wb = Nothing

Además:

' Cerrar la instancia de Excel Application
excelApp.Quit
Set excelApp = Nothing

Como mencionaba no estoy seguro que funcione pero es una idea, es con lo que puedo participar en tu consulta.

publicado

Prueba y comenta

Sub SumarEnRangoOptimizado()
    Dim folderPath As String
    Dim fileName As String
    Dim excelApp As Object
    Dim wb As Object
    Dim ws As Object
    Dim rng As Object
    
    ' Carpeta que contiene los archivos
    folderPath = "D:\Carpeta\"

    ' Deshabilitar actualizaciones de pantalla y cálculos automáticos
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' Crear una instancia de Excel Application
    On Error Resume Next ' Manejar errores al intentar conectar con una instancia existente
    Set excelApp = GetObject(, "Excel.Application")
    On Error GoTo 0 ' Reactivar la gestión de errores normales si no se encuentra ninguna instancia existente
    
    If excelApp Is Nothing Then
        Set excelApp = CreateObject("Excel.Application")
        excelApp.DisplayAlerts = False ' Desactivar las alertas
    End If

    ' Iterar sobre los archivos en la carpeta
    fileName = Dir(folderPath & "\*.xlsx")
    Do While fileName <> ""
        ' Abrir el archivo
        Set wb = excelApp.Workbooks.Open(folderPath & "\" & fileName)
        Set ws = wb.Sheets(1) ' Primera hoja de trabajo
        
        ' Aplicar la fórmula directamente en el rango
        With ws
            Set rng = .Range("A3239:D3850")
            With rng
                .Formula = "=A$3238 + (ROW()-3238)"
                .Value = .Value ' Convertir las fórmulas en valores
            End With
        End With
        
        ' Cerrar el archivo sin guardar cambios
        wb.Close SaveChanges:=True
        
        ' Obtener el siguiente archivo en la carpeta
        fileName = Dir
    Loop

    ' Cerrar la instancia de Excel Application
    excelApp.Quit
    Set excelApp = Nothing

    ' Habilitar actualizaciones de pantalla y cálculos automáticos
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "La operación se ha completado en todos los archivos de la carpeta.", vbInformation
End Sub

 

publicado
hace 3 horas, JSDJSD dijo:

Prueba y comenta

Sub SumarEnRangoOptimizado()
    Dim folderPath As String
    Dim fileName As String
    Dim excelApp As Object
    Dim wb As Object
    Dim ws As Object
    Dim rng As Object
    
    ' Carpeta que contiene los archivos
    folderPath = "D:\Carpeta\"

    ' Deshabilitar actualizaciones de pantalla y cálculos automáticos
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' Crear una instancia de Excel Application
    On Error Resume Next ' Manejar errores al intentar conectar con una instancia existente
    Set excelApp = GetObject(, "Excel.Application")
    On Error GoTo 0 ' Reactivar la gestión de errores normales si no se encuentra ninguna instancia existente
    
    If excelApp Is Nothing Then
        Set excelApp = CreateObject("Excel.Application")
        excelApp.DisplayAlerts = False ' Desactivar las alertas
    End If

    ' Iterar sobre los archivos en la carpeta
    fileName = Dir(folderPath & "\*.xlsx")
    Do While fileName <> ""
        ' Abrir el archivo
        Set wb = excelApp.Workbooks.Open(folderPath & "\" & fileName)
        Set ws = wb.Sheets(1) ' Primera hoja de trabajo
        
        ' Aplicar la fórmula directamente en el rango
        With ws
            Set rng = .Range("A3239:D3850")
            With rng
                .Formula = "=A$3238 + (ROW()-3238)"
                .Value = .Value ' Convertir las fórmulas en valores
            End With
        End With
        
        ' Cerrar el archivo sin guardar cambios
        wb.Close SaveChanges:=True
        
        ' Obtener el siguiente archivo en la carpeta
        fileName = Dir
    Loop

    ' Cerrar la instancia de Excel Application
    excelApp.Quit
    Set excelApp = Nothing

    ' Habilitar actualizaciones de pantalla y cálculos automáticos
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "La operación se ha completado en todos los archivos de la carpeta.", vbInformation
End Sub

 

Me marca error después de un rato igual que la mia.  Set wb = excelApp.Workbooks.Open(folderPath & "\" & fileName)

publicado
hace 8 horas, Israel Cassales dijo:

Hola, no tengo experiencia con ese error así que lo busque en Google y me devolvió esto:

El error ‘-2147023170(800706be) generalmente ocurre cuando se intenta acceder a un objeto que ya no está disponible.

Entonces no estoy seguro que lo siguiente funcione pero parece que al ser tantos archivos ocupa demasiada memoria en cada iteración del bucle. Si es así lo que podría recomendarte sería establecer los objetos de excel como wb y ws en el NOTHING después de que ya los uso.

Algo así:

' Cerrar el archivo sin guardar cambios
wb.Close SaveChanges:=True

' Liberar la memoria
Set ws = Nothing
Set wb = Nothing

Además:

' Cerrar la instancia de Excel Application
excelApp.Quit
Set excelApp = Nothing

Como mencionaba no estoy seguro que funcione pero es una idea, es con lo que puedo participar en tu consulta.

Igual me marca el mismo error  ‘-2147023170(800706be)

publicado
hace 3 horas, cathyuska dijo:

Igual me marca el mismo error  ‘-2147023170(800706be)

Disculpa me da este error: El error 462 "El equipo servidor remoto no existe o no está disponible" y en depurar :  wb.Close SaveChanges:=True

 
publicado

En ese caso es parece que está intentando cerrar un libro (wb) que ya se ha liberado.

Así que lo que podría agregar entonces es verificar el objeto antes de cerrarlo, intenta modificar el código:

' Cerrar el archivo sin guardar cambios
If Not wb Is Nothing Then
    wb.Close SaveChanges:=True
    Set wb = Nothing
End If

Algo así verificará si el objeto wb existe (If Not wb Is Nothing) antes de intentar cerrarlo (wb.Close SaveChanges:=True). Si wb no existe, entonces el código para cerrarlo no se ejecutará, tratando de evitar el error

publicado

Hola

Pregunta ¿Ejecutas esa macro directamente del archivo o cómo? Lo pregunto porque creas una instancia Excel y no me queda claro, ya que el método Open del objeto Workbooks actúa sin necesidad de crear una nueva instancia. 

publicado
hace 4 horas, Abraham Valencia dijo:

Hola

Pregunta ¿Ejecutas esa macro directamente del archivo o cómo? Lo pregunto porque creas una instancia Excel y no me queda claro, ya que el método Open del objeto Workbooks actúa sin necesidad de crear una nueva instancia. 

Hola, directo del archivo

publicado

Parece ser cosa de la memoria y recursos de tu PC. Igual intenta así:

 

Sub SumarEnRangoOptimizado()
    
    Dim folderPath As String
    Dim fileName As String
    Dim wb As Workbook
    Dim ws As Worksheet
    
    ' Carpeta que contiene los archivos
    folderPath = "D:\Carpeta\"

    ' Deshabilitar actualizaciones de pantalla y cálculos automáticos
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' Crear una instancia de Excel Application
 '   Set excelApp = CreateObject("Excel.Application")
 '   excelApp.DisplayAlerts = False ' Desactivar las alertas

    ' Iterar sobre los archivos en la carpeta
    fileName = Dir(folderPath & "\*.xlsx")
    Do While fileName <> ""
        ' Abrir el archivo
        Set wb = Workbooks.Open(folderPath & "\" & fileName)
        Set ws = wb.Sheets(1) ' Primera hoja de trabajo
        
        ' Aplicar la fórmula directamente en el rango
        With ws
            .Range("A3239:D3850").Formula = "=A$3238 + (ROW()-3238)"
            .Range("A3239:D3850").Value = .Range("A3239:D3850").Value ' Convertir las fórmulas en valores
        End With
        
        ' Cerrar el archivo sin guardar cambios
        wb.Close SaveChanges:=True
        
        Set ws = Nothing
        Set wb = Nothing
        
        ' Obtener el siguiente archivo en la carpeta
        fileName = Dir
    Loop

    ' Cerrar la instancia de Excel Application
   ' excelApp.Quit
  '  Set excelApp = Nothing

    ' Habilitar actualizaciones de pantalla y cálculos automáticos
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "La operación se ha completado en todos los archivos de la carpeta.", vbInformation
End Sub

Comentas

publicado
En 29/2/2024 at 20:10 , Abraham Valencia dijo:

Parece ser cosa de la memoria y recursos de tu PC. Igual intenta así:

 

Sub SumarEnRangoOptimizado()
    
    Dim folderPath As String
    Dim fileName As String
    Dim wb As Workbook
    Dim ws As Worksheet
    
    ' Carpeta que contiene los archivos
    folderPath = "D:\Carpeta\"

    ' Deshabilitar actualizaciones de pantalla y cálculos automáticos
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' Crear una instancia de Excel Application
 '   Set excelApp = CreateObject("Excel.Application")
 '   excelApp.DisplayAlerts = False ' Desactivar las alertas

    ' Iterar sobre los archivos en la carpeta
    fileName = Dir(folderPath & "\*.xlsx")
    Do While fileName <> ""
        ' Abrir el archivo
        Set wb = Workbooks.Open(folderPath & "\" & fileName)
        Set ws = wb.Sheets(1) ' Primera hoja de trabajo
        
        ' Aplicar la fórmula directamente en el rango
        With ws
            .Range("A3239:D3850").Formula = "=A$3238 + (ROW()-3238)"
            .Range("A3239:D3850").Value = .Range("A3239:D3850").Value ' Convertir las fórmulas en valores
        End With
        
        ' Cerrar el archivo sin guardar cambios
        wb.Close SaveChanges:=True
        
        Set ws = Nothing
        Set wb = Nothing
        
        ' Obtener el siguiente archivo en la carpeta
        fileName = Dir
    Loop

    ' Cerrar la instancia de Excel Application
   ' excelApp.Quit
  '  Set excelApp = Nothing

    ' Habilitar actualizaciones de pantalla y cálculos automáticos
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "La operación se ha completado en todos los archivos de la carpeta.", vbInformation
End Sub

Comentas

lo hice. Hizo mas lento la ejecución pero esta bien. Gracias

Archivado

Este tema está ahora archivado y está cerrado a más respuestas.

  • 109 ¿Te parecen útiles los tips de las funciones? (ver tema completo)

    1. 1. ¿Te parecen útiles los tips de las funciones?


      • No
      • Ni me he fijado en ellos

  • Ayúdanos a mejorar la comunidad

    • Donaciones recibidas este mes: 0.00 EUR
      Objetivo: 130.00 EUR
  • Archivos

  • Estadísticas de descargas

    • Archivos
      188
    • Comentarios
      98
    • Revisiones
      29

    Más información sobre "Cambios en el Control Horario"
    Última descarga
    Por pegones1

    4    1

  • Crear macros Excel

  • Mensajes

    • Buenos días  @LeandroA espero estes bien Tengo un caso idéntico al planteado en la siguiente pregunta: Sin embargo, a diferencia de quien planteo originalmente la pregunta al correr el código no obtengo ningún resultado podrían ayudarme a resolver este inconveniente y que al hacer click en el Botón Guardar (CommandButton3) del Formulario RCS (frmrcs) el archivo pdf quede configurado con orientación vertical, márgenes superior, inferior, derecho e izquierdo = 1 y en página tamaño carta. Si acaso influye uso Microsoft Excel LTSC MSO (versión 2209 Compilación16.0.1.15629.20200) de 64 bits Mucho le sabre agradecer la ayuda que me pueda dar  RCS PRUEBA - copia.xlsm
    • @JSDJSDCon gusto mi estimado Para la opción 1: Sub Surtirhastadondealcanse() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets(1) Dim filaInicio As Integer: filaInicio = 4 Dim filaFin As Integer: filaFin = 7 Dim colInventario As Integer: colInventario = 2 Dim colSolicitudesInicio As Integer: colSolicitudesInicio = 4 ' Columna C Dim colResultadoInicio As Integer: colResultadoInicio = 9 ' Columna I Dim colTotalSurtido As Integer: colTotalSurtido = 12 ' Columna L Dim colFinalInventario As Integer: colFinalInventario = 13 ' Columna M Dim numClientes As Integer: numClientes = 3 Dim fila As Integer, i As Integer For fila = filaInicio To filaFin Dim inventario As Double inventario = Val(ws.Cells(fila, colInventario).Value) Dim solicitudes(1 To 3) As Double Dim surtido(1 To 3) As Variant Dim totalSurtido As Double: totalSurtido = 0 ' Leer solicitudes For i = 1 To numClientes If IsNumeric(ws.Cells(fila, colSolicitudesInicio + i - 1).Value) Then solicitudes(i) = CDbl(ws.Cells(fila, colSolicitudesInicio + i - 1).Value) Else solicitudes(i) = 0 End If surtido(i) = "POR FALTA STOCK" Next i ' Surtir de acuerdo al inventario disponible For i = 1 To numClientes If solicitudes(i) > 0 Then If inventario >= solicitudes(i) Then surtido(i) = solicitudes(i) inventario = inventario - solicitudes(i) totalSurtido = totalSurtido + solicitudes(i) ElseIf inventario > 0 Then surtido(i) = inventario totalSurtido = totalSurtido + inventario inventario = 0 Else surtido(i) = "POR FALTA STOCK" End If End If Next i ' Escribir resultados en las columnas correspondientes para cada cliente For i = 1 To numClientes With ws.Cells(fila, colResultadoInicio + i - 1) If surtido(i) = "POR FALTA STOCK" Then .Value = surtido(i) .Font.Color = vbRed Else .Value = surtido(i) .Font.Color = vbBlack End If End With Next i ' Escribir total surtido y existencia final ws.Cells(fila, colTotalSurtido).Value = totalSurtido ws.Cells(fila, colFinalInventario).Value = inventario Next fila MsgBox "Resultado surtido cargado con éxito...", vbInformation End Sub Para la opción 2:   Sub surtirenpartesiguales() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets(1) Dim filaInicio As Integer: filaInicio = 13 Dim filaFin As Integer: filaFin = 16 Dim colInventario As Integer: colInventario = 2 Dim colSolicitudesInicio As Integer: colSolicitudesInicio = 4 ' Columna C Dim colResultadoInicio As Integer: colResultadoInicio = 9 ' Columna I Dim colTotalSurtido As Integer: colTotalSurtido = 12 ' Columna L Dim colFinalInventario As Integer: colFinalInventario = 13 ' Columna M Dim numClientes As Integer: numClientes = 3 Dim fila As Integer, i As Integer For fila = filaInicio To filaFin Dim inventario As Double inventario = Val(ws.Cells(fila, colInventario).Value) Dim solicitudes(1 To 3) As Double Dim surtido(1 To 3) As Variant Dim totalSurtido As Double: totalSurtido = 0 Dim totalPedido As Double: totalPedido = 0 ' Leer solicitudes For i = 1 To numClientes If IsNumeric(ws.Cells(fila, colSolicitudesInicio + i - 1).Value) Then solicitudes(i) = CDbl(ws.Cells(fila, colSolicitudesInicio + i - 1).Value) totalPedido = totalPedido + solicitudes(i) Else solicitudes(i) = 0 End If surtido(i) = 0 Next i ' Si hay suficiente inventario, surtir lo que el cliente pide If inventario >= totalPedido Then For i = 1 To numClientes If solicitudes(i) > 0 And inventario >= solicitudes(i) Then surtido(i) = solicitudes(i) inventario = inventario - solicitudes(i) totalSurtido = totalSurtido + solicitudes(i) End If Next i Else ' Reparto base igualitario Dim baseSurtido As Long baseSurtido = Int(inventario / numClientes) For i = 1 To numClientes If solicitudes(i) > 0 Then If solicitudes(i) <= baseSurtido Then surtido(i) = solicitudes(i) inventario = inventario - solicitudes(i) totalSurtido = totalSurtido + solicitudes(i) Else surtido(i) = baseSurtido inventario = inventario - baseSurtido totalSurtido = totalSurtido + baseSurtido End If End If Next i ' Repartir sobrante restante uno por uno, respetando lo pedido Do While inventario > 0 For i = 1 To numClientes If surtido(i) < solicitudes(i) Then surtido(i) = surtido(i) + 1 totalSurtido = totalSurtido + 1 inventario = inventario - 1 If inventario = 0 Then Exit For End If Next i Loop End If ' Escribir resultados en las columnas correspondientes para cada cliente For i = 1 To numClientes With ws.Cells(fila, colResultadoInicio + i - 1) If surtido(i) = 0 Then .Value = "POR FALTA STOCK" .Font.Color = vbRed Else .Value = surtido(i) .Font.Color = vbBlack End If End With Next i ' Escribir total surtido y existencia final ws.Cells(fila, colTotalSurtido).Value = totalSurtido ws.Cells(fila, colFinalInventario).Value = inventario Next fila MsgBox "Resultado surtido cargado con éxito...", vbInformation End Sub Saludos, Diego
    • Buenos dias.  Estoy trabajando en una hoja para poder llevar un control de un pequeño almacén.  Tengo un pedido con varias líneas y "lotes" y necesito sacar las ubicaciones que coincidan con la referencia y lote que pone en el pedido. El problema viene cuando tengo la misma referencia y mismo lote en ubicaciones diferentes y necesito sacar la información en columnas diferentes. No se si  me he explicado bien, pero creo que con el ejemplo adjunto se entiende mejor. Agradecería mucho si me pudieran ayudar  Libro1.xlsx
    • Exelente solución mil gracias 
    • Podrías compartir tu solucion
  • Visualizado recientemente

    • No hay usuarios registrado para ver esta página.
×
×
  • Crear nuevo...

Información importante

Echa un vistazo a nuestra política de cookies para ayudarte a tener una mejor experiencia de navegación. Puedes ajustar aquí la configuración. Pulsa el botón Aceptar, si estás de acuerdo.