No está mal la macro que has hecho. Bueno, mi idea es esta:
Código:
Function ExportData(ByVal FileName As String, ByVal DataFile As String, Optional ByVal Count As Integer = 2) As Integer
Dim NewXLS As Excel.Application
Dim NewBook As Workbook
Dim NewSheet As Worksheet
Set NewXLS = New Excel.Application
Set NewBook = NewXLS.Workbooks.Open(FileName)
Set NewSheet = NewBook.Worksheets(1)
'Agregamos los encabezados
NewSheet.Range("A1") = "Propietario"
NewSheet.Range("B1") = "Puntos"
NewSheet.Range("C1") = "Alianza"
NewSheet.Range("D1") = "Coordenadas"
NewSheet.Range("E1") = "Situación"
Dim dataXLS As Workbook
Set dataXLS = NewXLS.Workbooks.Open(DataFile)
Dim dataSheet As Worksheet
Set dataSheet = dataXLS.Worksheets(1)
Dim Looping As Byte
'Recorremos desde la primera fila hasta la fila 150
For Looping = 1 To 150
If dataSheet.Range("A" & Looping) = "Propietario" Then
'Extraemos propietario
NewSheet.Range("A" & Count) = dataSheet.Range("B" & Looping)
'Extraemos Puntos
NewSheet.Range("B" & Count) = dataSheet.Range("B" & (Looping + 1))
'Extraemos Alianza
NewSheet.Range("C" & Count) = dataSheet.Range("B" & (Looping + 4))
'Extraemos Coordenadas
NewSheet.Range("D" & Count) = dataSheet.Range("B" & (Looping + 2))
'Extraemos Situación
NewSheet.Range("E" & Count) = dataSheet.Range("B" & (Looping + 5))
'Saltamos los datos extraídos
Looping = Looping + 6
Count = Count + 1
End If
Next Looping
dataXLS.Close False
NewBook.Close True
NewXLS.Quit
Set dataXLS = Nothing
Set NewBook = Nothing
Set NewXLS = Nothing
ExportData = Count
End Function
Los parámetros son:
FileName: archivo donde se guardarán los datos
DataFile: archivo desde donde se extraerán los datos
Count: En qué rango empezará a escribir los datos
La función devuelve un entero con el valor de la primera celda vacía en el archivo de salida.
Con esa función ya te será fácil hacer el For que recorra todos los archivos y guarde los datos...
Espero que te sirva. Saludos
