Extraer rango de todos los archivos de una carpeta

[lucas_545]

Hola amigos del foro, utilizo actualmente el siguiente código para extraer un rango datos de todas las hojas de un libro y colocarlo en otra hoja. Este libro se hizo con el tiempo cada vez más pesado y tuve que hacer un libro para cada hoja, pues aquí radica mi problema: tengo que ajustar mi código para buscar en todos los archivos de la carpeta.

On Error Resume Next


Dim wrbLibro As Workbook

Dim wrsHojaActiva As Worksheet, wsHoja As Worksheet

Dim CurFilename As String

CurFilename = Sheets("RANGOS").Range("A1")

Set wrbLibro = Workbooks(CurFilename)

Set wrsHojaActiva = ThisWorkbook.Sheets("RESUMEN")


For Each wsHoja In wrbLibro.Worksheets


If wsHoja.Name = "VIAJES" Then GoTo ProxHoja

If wsHoja.Name = "A" Then GoTo ProxHoja

If wsHoja.Name = "B" Then GoTo ProxHoja

If wsHoja.Name = "D" Then GoTo ProxHoja

If wsHoja.Name = "BUSCADOR" Then GoTo ProxHoja

If wsHoja.Name = "LLAMADAS" Then GoTo ProxHoja

If wsHoja.Name <> wrsHojaActiva.Name Then

wsHoja.Range(Worksheets("RANGOS").Range("D2")).Copy

uf = Sheets("RESUMEN").Range("B" & Cells.Rows.Count).End(xlUp).Row + 1

Sheets("RESUMEN").Range("A" & uf).PasteSpecial

End If

ProxHoja:

Next wsHoja

Sheets("RESUMEN").Select

Call BORRAR_VACIAS

Call SIN_RELLENO

Call POR_CODIGO

Call POR_CTACTE

    Range("B" & Cells.Rows.Count).End(xlUp).Select

    Sheets("RANGOS").Select[/CODE]

Nota: todos los archivos son iguales.

Muchas gracias.

[bigpetroman]

amigo, te recomiendo que subas tu archivo de excel y expliques mejor cual es el problema, normalmente con el código solo NO se puede hacer nada, suerte

[lucas_545]

Gracias bigpetroman, adjunto el archivo.

Resumen.rar

[bigpetroman]

amigo NO he podido revisarlo ya que me quede ayer sin internet en la casa, y en el trabajo tengo el office 2003 y no puedo abrir el archivo, suerte, esperemos a ver si alguien mas te ayuda o lo subes en excel 2003 para poder revisarlo

[lucas_545]

Les cuento amigos que mi nivel de programación es algo corto, por eso me limito a tomar ejemplos del foro y adaptarlos a mi proyecto.

De todas formas quisiera compartir con el foro el siguiente código que logré hacer funcionar para extraer rangos de todos los libros de una carpeta.

Dim CurFilename As String

    CurFilename = Sheets("RANGOS").Range("A1")

    Dim CurRango

    CurRango = Sheets("RANGOS").Range("D2")


ChDir (ThisWorkbook.Path & "\" & CurFilename)

arcact = ActiveWorkbook.Name

Dim arch As String

arch = Dir("*.xlsb")

Do Until arch = ""

If arch = arcact Then GoTo Salto

Workbooks.Open Filename:=arch

Range(CurRango).Copy

uf = Workbooks("Resumen").Sheets("RESUMEN").Range("B" & Cells.Rows.Count).End(xlUp).Row + 1

Workbooks("Resumen").Sheets("RESUMEN").Range("A" & uf).PasteSpecial 'Se pegan los datos

Workbooks(arch).Close

Salto:

arch = Dir

Loop

[/CODE]

[lucas_545]

***************** Tema solucionado. Muchas gracias ****************