El método Copy del objeto Range ha fallado
Herkabe
Mensajes publicados
18
Estado
Miembro
-
Patrice33740 Mensajes publicados 8400 Fecha de registro Estado Miembro Última intervención -
Patrice33740 Mensajes publicados 8400 Fecha de registro Estado Miembro Última intervención -
Hola,
Ya pasé por aquí hace dos o tres días para ayudarme a codificar mi compilador, cosa que finalmente logré hacer gracias a Patrice.
Sin embargo, me gustaría usar el compilador para todo tipo de forma de datos (es decir, independientemente de la variación en el número de filas o columnas).
En los archivos de origen que quería compilar, había unas centenas de filas por archivo, para 13 columnas y 2 filas de encabezado. En los nuevos archivos, siempre unas cientos de filas pero ahora hay 19 columnas.
La macro, que funciona muy bien para compilar archivos con 13 columnas, de repente ya no funciona para archivos que tienen más de 13 columnas (aún no probé para menos).
Aquí está el código :
Para los dos tipos de archivos, hay que copiar a partir de la línea 5, pero he probado con todas las columnas la constante col, ¡no funciona!
Aquí hay imágenes de los archivos para dar una idea:
Mi pregunta: ¿Qué hay que cambiar en el código para poder adaptarlo fácilmente a todo tipo de archivos (el error está localizado en la línea rng.Copy dst)?
Ya pasé por aquí hace dos o tres días para ayudarme a codificar mi compilador, cosa que finalmente logré hacer gracias a Patrice.
Sin embargo, me gustaría usar el compilador para todo tipo de forma de datos (es decir, independientemente de la variación en el número de filas o columnas).
En los archivos de origen que quería compilar, había unas centenas de filas por archivo, para 13 columnas y 2 filas de encabezado. En los nuevos archivos, siempre unas cientos de filas pero ahora hay 19 columnas.
La macro, que funciona muy bien para compilar archivos con 13 columnas, de repente ya no funciona para archivos que tienen más de 13 columnas (aún no probé para menos).
Aquí está el código :
Option Explicit
Sub TEST2()
Dim fso As Object 'Sistema de archivos
Dim rep As Object 'Directorio
Dim cfr As Object 'Colección de archivos del directorio
Dim fic As Object 'Archivo (elemento de la colección cfr)
Dim wbk As Workbook 'Libro de trabajo
Dim res As Workbook 'Libro de trabajo resultado
Dim rng As Range 'Rango de celdas
Dim dst As Range 'Celda de destino
Dim pth As String 'Camino del directorio
Dim etc As Boolean 'Encabezado copiado
Const lig$ = "5" 'Dirección de la primera fila de las tablas a copiar
Const col$ = "F" 'Dirección de la columna a probar
' Definir el directorio a leer
pth = "C:\Users\vdesigau\Desktop\Reporting WC\BA"
' Crear el archivo resultado
Set res = Workbooks.Add(xlWBATWorksheet)
Set dst = res.Worksheets(1).Range("A1")
' Lectura del directorio
Set fso = CreateObject("Scripting.FileSystemObject")
Set rep = fso.GetFolder(pth)
Set cfr = rep.Files
' Controlar cada archivo del directorio
For Each fic In cfr
' - Verificar si es un archivo de Excel...
If StrComp(fso.GetExtensionName(fic.Name), "xls", vbTextCompare) = 0 Then
' ... en caso afirmativo, abrir el archivo y actualizar las conexiones
Set wbk = Workbooks.Open(Filename:=pth & "\" & fic.Name, UpdateLinks:=xlUpdateLinksAlways)
' Definir las filas a copiar
With wbk.Worksheets(1)
Set rng = .Rows(lig & ":" & .Cells(.Rows.Count, col).End(xlUp).Row)
End With
' Si el encabezado ya está copiado ....
If etc Then
' ... reducir las filas a los datos sin encabezado
Set rng = rng.Offset(3).Resize(rng.Rows.Count - 3)
End If
' Copiar las filas enteras
rng.Copy dst
' Encabezado copiado
etc = True
' Próxima destino
Set dst = dst.Offset(rng.Rows.Count)
' Cerrar el archivo sin modificarlo
wbk.Close False
End If
Next fic
End Sub
Para los dos tipos de archivos, hay que copiar a partir de la línea 5, pero he probado con todas las columnas la constante col, ¡no funciona!
Aquí hay imágenes de los archivos para dar una idea:
Mi pregunta: ¿Qué hay que cambiar en el código para poder adaptarlo fácilmente a todo tipo de archivos (el error está localizado en la línea rng.Copy dst)?
2 respuestas
-
Hola,
La macro no depende del número de columnas porque copia filas enteras.
Hay que ajustar las constantes lig y col:
- lig es la primera fila de los títulos de la tabla, por lo que en el segundo caso = 1.
- col es la columna que se usa para determinar el número de filas a copiar; = "F" me parece la opción correcta.
Por otro lado, tus nuevos cuadros tienen 5 filas de título (en lugar de 3), por lo que hay que sustituir
Set rng = rng.Offset(3).Resize(rng.Rows.Count - 3)
por
Set rng = rng.Offset(5).Resize(rng.Rows.Count - 5)
--
Cordialmente
Patrice-
Para un procedimiento simple de configurar:
Option Explicit Sub Regrouper_Fichiers() Dim fso As Object 'Sistema de archivos Dim rep As Object 'Directorio Dim cfr As Object 'Colección de archivos del directorio Dim fic As Object 'Archivo (elemento de la colección cfr) Dim wbk As Workbook 'Classeur Dim res As Workbook 'Classeur resultado Dim rng As Range 'Rango de celdas Dim dst As Range 'Celda de destino Dim pth As String 'Ruta del directorio Dim etc As Boolean 'Encabezado copiado Const lig$ = "1" 'Dirección de la primera fila de las tablas a copiar Const col$ = "F" 'Dirección de la columna a probar Const nlt& = 5 'Número de filas de título a copiar (una sola vez) ' Definir el directorio a leer pth = ThisWorkbook.Path & "\tmp" ' Crear el archivo resultado Set res = Workbooks.Add(xlWBATWorksheet) Set dst = res.Worksheets(1).Range("A1") ' Lectura del directorio Set fso = CreateObject("Scripting.FileSystemObject") Set rep = fso.GetFolder(pth) Set cfr = rep.Files ' Recorrer cada archivo del directorio For Each fic In cfr ' - Verificar si se trata de un archivo de Excel... If StrComp(fso.GetExtensionName(fic.Name), "xls", vbTextCompare) = 0 Then ' ... en caso afirmativo, abrir el archivo y actualizar las referencias Set wbk = Workbooks.Open(Filename:=pth & "\" & fic.Name, UpdateLinks:=xlUpdateLinksAlways) ' Definir las filas a copiar With wbk.Worksheets(1) Set rng = .Rows(lig & ":" & .Cells(.Rows.Count, col).End(xlUp).Row) End With ' Si el encabezado ya está copiado ... If etc Then ' ... reducir las filas a los datos sin encabezado Set rng = rng.Offset(nlt).Resize(rng.Rows.Count - nlt) End If ' Copiar las filas enteras rng.Copy dst ' Encabezado copiado etc = True ' Siguiente destino Set dst = dst.Offset(rng.Rows.Count) ' Cerrar el archivo sin modificar wbk.Close False End If Next fic End Sub
-
-
Hola Patrice y gracias por tu gran rapidez.
Después de aplicar las modificaciones que me dijiste, tengo un error 1004: definido por la aplicación o por el objeto, para la líneaSet rng = rng.Offset(5).Resize(rng.Rows.Count - 5)
