Hola Frank!
En realidad tuve que adoptar más suposiciones de las que me hubiesen gustado. A saber:
a) Que en "companias.xls" los 16 datos están en la columna A y a partir de la fila 2, reservándose la fila 1 para: "RAZSOC".
b) Que el número de razones sociales puede cambiar.
c) Que el número de hojas de "midirectorio.xls" puede cambiar (diferir de 15).
d) Que dentro de los 4 registros de cada una de las 15 hojas la razón social se puede repetir
e) Que el número de registros pueden cambiar (diferir de 4).
Luego de lo anterior, resultó el siguiente código:
Código:
Sub BuscaEn15()
Dim CeldaRes As Range, RangoRazSoc As Range, CeldaEnc As Range
Dim FileRazSoc As String, FileDatos As String
Dim SheetCounter As Integer, ii As Integer
Application.ScreenUpdating = False
FileRazSoc = "companias.xls"
FileDatos = "midirectorio.xls"
Set CeldaRes = [A65536]
CeldaRes.End(xlUp).Offset(0, 7) = "Origen"
Windows(FileRazSoc).Activate
Set RangoRazSoc = Range([A2], [A65536].End(xlUp))
Windows(FileDatos).Activate
Do
SheetCounter = SheetCounter + 1
For ii = 1 To RangoRazSoc.Rows.Count
Application.Goto Sheets(SheetCounter).[A1]
OtroRegistroEnLaHoja:
On Error Resume Next
Set CeldaEnc = _
Cells.Find(What:=RangoRazSoc.Cells(ii), _
After:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False)
On Error GoTo 0
If CeldaEnc Is Nothing Then GoTo OtraRazSoc
If CeldaEnc.Address = ActiveCell.Address Then GoTo OtraRazSoc
If CeldaEnc.Row < ActiveCell.Row Then GoTo OtraRazSoc
CeldaEnc.Select
Set CeldaEnc = Selection.Offset(0, 1 - CeldaEnc.Column)
Range(CeldaEnc, CeldaEnc.Offset(0, 6)).Copy _
Destination:=CeldaRes.End(xlUp).Offset(1, 0)
CeldaRes.End(xlUp).Offset(0, 7) = ActiveSheet.Name
GoTo OtroRegistroEnLaHoja
OtraRazSoc:
Next ii
Loop While ActiveSheet.Name <> Sheets(Sheets.Count).Name
Application.Goto CeldaRes.Offset(-65535, 0)
Application.ScreenUpdating = True
Cells.Columns.AutoFit
Set CeldaEnc = Nothing
Set RangoRazSoc = Nothing
Set CeldaRes = Nothing
End Sub
Uso:
1) Tener abiertos los archivos "companias.xls" y "midirectorio.xls".
2) Tener abierto el archivo resumen (no interesa su nombre) en la hoja en la que se copiará la información.
Esta hoja deberá estar "en blanco", a excepción de su primera fila en la que tú le habrás puesto los nombres de los 7 campos.
3) En este mismo "archivo resumen" deberá residir el código de macro que acompaño.
4) Finalmente al correr el código "
BuscaEn15" y luego de unos instantes:
puede ser que tengas suerte... (je je je).
5) Notar que el nombre de los archivos "companias.xls" y "midirectorio.xls" se puede parametrizar dentro del código.
Prueba con lo anterior y luego cuéntanos como te fue.
Saludos.
Función o macro para encontrar y copiar 
Función o macro para encontrar y copiar 
Respuesta: Función o macro para encontrar y copiar 
Respuesta: Función o macro para encontrar y copiar 
