Option Explicit
Sub Bton_Empezar()
'Lo unico que no hago es una vez que se crean los libros nuevos es grabarlos.
'Si pulsas el boton y se crean nuevos libros, si lo vuelves a pulsar se crearan nuevos libros nuevamente, tampoco lo controlo.
Dim Libros As Workbook 'Objetos Libros
Dim Hojas As Worksheet 'Objetos Hojas
Dim strEsteFic As String 'Nombre de este Fichero
Dim strEstaPes As String 'Nombre de esta Pestaña
Dim nRangoFind As Range 'Rango de Busqueda
Dim Dic_Tecnico As Dictionary 'Necesitas Referencia M. Scripting Runtime
Dim nColIniTec As Integer, nColFinTec As Integer, nLinIniTec As Integer, nLinFinTec As Long
Dim nLn As Integer, i As Integer
Dim Mat_Libro_Tec As Variant 'Matriz para guardar los nombres de libros + 1
Dim Abierto As Boolean
On Error GoTo Errores
strEsteFic = Application.ThisWorkbook.Name
strEstaPes = Application.ActiveSheet.Name
Set Dic_Tecnico = New Dictionary
ReDim Mat_Libro_Tec(0) 'Recordar que es + 1
Call f_OnOff(False)
Application.StatusBar = "Comenzando ..."
'Recorremos los datos
If Worksheets(strEstaPes).AutoFilterMode Then ActiveSheet.AutoFilterMode = False
Application.CutCopyMode = False
Rows("1:1").Select
Set nRangoFind = Selection.Find(What:="TECNICO", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not nRangoFind Is Nothing And Err.Number = 0 Then
nLinIniTec = nRangoFind.Row 'Fila Inicio Tecnico
nLinFinTec = ActiveSheet.Range("A1048575").End(xlUp).Row 'Lin Fin Tecnico
nColIniTec = nRangoFind.Column 'Columna Tecnico
nColFinTec = Selection.End(xlToRight).Column 'Fin Columna Tecnico
'Almacenamos en la matriz los elementos
Range("A1").Select
For nLn = (nLinIniTec + 1) To nLinFinTec
If Not Dic_Tecnico.Exists(Worksheets(strEstaPes).Cells(nLn, nColIniTec).Value) Then Dic_Tecnico.Add Worksheets(strEstaPes).Cells(nLn, nColIniTec).Value, nLn
Next nLn
If (Not Dic_Tecnico Is Nothing) Then
If Dic_Tecnico.Count > 0 Then
'Ahora creamos los libros segun la matriz
For i = 0 To Dic_Tecnico.Count - 1
Application.StatusBar = "Creando Tecnico " & Dic_Tecnico.Keys(i)
Abierto = False
Workbooks(strEsteFic).Activate
Range("A1").Select
Application.CutCopyMode = False
'Miramos que no exista ya el libro
'Para ello solamente comprobamos 4 cosas
'1) que el libro tenga una sola pestaña asi ahorramos mirar mas
'2) Que el nombre de la pestaña sea igual que el codigo del Tecnico
'3) Que exista la columna TECNICO
'4) Que el primer valor se igual al tecnico
For Each Libros In Workbooks
If LCase(Libros.Name) <> LCase(strEsteFic) Then
Workbooks(Libros.Name).Activate
For Each Hojas In Worksheets
If Worksheets.Count < 2 Then
If Hojas.Name = CStr(Dic_Tecnico.Keys(i)) Then
Rows("1:1").Select
Set nRangoFind = Selection.Find(What:="TECNICO", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not nRangoFind Is Nothing And Err.Number = 0 Then
If Worksheets(Hojas.Name).Cells(nRangoFind.Row + 1, nRangoFind.Column).Value = Dic_Tecnico.Keys(i) Then
Abierto = True
ReDim Preserve Mat_Libro_Tec(UBound(Mat_Libro_Tec) + 1)
Mat_Libro_Tec(UBound(Mat_Libro_Tec)) = Libros.Name
'Como esta abierto lo borramos antes, si nos interesa entonces quitemos este codigo
Cells.ClearContents
Range("A1").Select
Exit For
End If
End If
End If
End If
Next
If Abierto Then Exit For
End If
Next
If Not Abierto Then
ActiveWorkbook.Application.Workbooks.Add
If Worksheets.Count > 2 Then
For Each Hojas In Worksheets
If (Hojas.Name <> "Hoja1") Then Worksheets(Hojas.Name).Delete
Next
End If
Sheets("Hoja1").Name = Dic_Tecnico.Keys(i)
'Guardamos los nombres de los libros en una matriz
ReDim Preserve Mat_Libro_Tec(UBound(Mat_Libro_Tec) + 1)
Mat_Libro_Tec(UBound(Mat_Libro_Tec)) = ActiveWorkbook.Name
End If
If UBound(Mat_Libro_Tec) > 0 Then
'Ahora vamos a rellenar los libros con los datos
Workbooks(strEsteFic).Activate
Application.CutCopyMode = False
If Not Worksheets(strEstaPes).AutoFilterMode Then Selection.AutoFilter
ActiveSheet.Range(Cells(nLinIniTec, 1), Cells(nLinFinTec, nColFinTec)).AutoFilter Field:=nColIniTec, Criteria1:=Dic_Tecnico.Keys(i)
Cells.Select
Selection.Copy
Workbooks(Mat_Libro_Tec(i + 1)).Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Cells.Select
Cells.EntireColumn.AutoFit
Range("A1").Select
End If
Next i
Workbooks(strEsteFic).Activate
If Worksheets(strEstaPes).AutoFilterMode Then ActiveSheet.AutoFilterMode = False
Range("A1").Select
Application.CutCopyMode = False
Else
MsgBox "No hay tecnicos", vbCritical, "ERROR"
End If
End If
Else
MsgBox "No existe la cabecera de 'Tecnico'", vbCritical, "ERROR"
End If
Dic_Tecnico.RemoveAll
If (Not Dic_Tecnico Is Nothing) Then Set Dic_Tecnico = Nothing
Call f_OnOff
Application.StatusBar = vbNullString
MsgBox "Fin del proceso", vbInformation, "AVISO"
Exit Sub
Errores:
Application.DisplayStatusBar = True
MsgBox Err.Description, vbCritical, "ERROR"
End Sub
Function f_OnOff(Optional ByRef t_Estado As Boolean = True)
On Error GoTo Errores
Application.DisplayAlerts = t_Estado
Application.ScreenUpdating = t_Estado
Application.EnableEvents = t_Estado
Exit Function
Errores:
Resume Next
End Function
