Bienvenido a la mayor comunidad de usuarios EXCEL

Regístrate ahora y podrás: / 💪 Hacer preguntas a los expertos / ⬇️ Descargar ejemplos y plantillas / 🏅 Acceder a contenidos premium

Regístrate gratis

Macro para filtrar, copiar y pegar datos a libros nuevos

Osvaldo_83

New member
Muy buenos dias.

Tengo un libro con datos en columnas. Una de las columnas tiene códigos diferentes. Así:ejemplo1.PNG

Necesito una macro que filtre en la columna Tecnico los codigos existentes y que lleve los datos por separado a libros nuevos. En el caso del ejemplo debe crearse un libro con los datos del filtro con el codigo 102 otro libro para el 182 y otro libro para el 185. es un trabajo que se podria realizar manual pero diariamente debo realizarlo con aproximandamente 30 codigos direntes, es decir sacar 30 archivos.
 

Adjuntos

  • Ejemplo (1).xlsx
    16,1 KB · Visitas: 3

novirus

New member
Buenas,

He aprovechado código de otros excel que tengo para realizarte este.
*) Carga en una matriz dictionary los tecnicos para que no se repitan,
*) Crea libros nuevos con el nombre de la pestaña de cada tecnico, previamente verifica que ya no exista un fichero abierto con 4 pasos.
*) Si existe borra la informacion.
*) Filtra del fichero principal el Tecnico y lo copia al libro (nuevo o ya existente).

Que no hace:
*) Guarda los libros nuevos, deberas poner un codigo que SAVEAS que los grabe, eso ya es cosa tuya.

Espero te sirva.

Deberás crear un botón y asignarle la macro: Bton_Empezar()
No puedo adjuntar el modulo así que te adjunto el fichero excel con el modulo, pero por si acaso, lo escribo aquí:

Código:
Option Compare Text
Código:
Código:
Código:
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



Un saludo.
 

Adjuntos

  • Ejemplo (2) - Ayuda.xlsm
    36 KB · Visitas: 0

Osvaldo_83

New member
Buenas,

He aprovechado código de otros excel que tengo para realizarte este.
*) Carga en una matriz dictionary los tecnicos para que no se repitan,
*) Crea libros nuevos con el nombre de la pestaña de cada tecnico, previamente verifica que ya no exista un fichero abierto con 4 pasos.
*) Si existe borra la informacion.
*) Filtra del fichero principal el Tecnico y lo copia al libro (nuevo o ya existente).

Que no hace:
*) Guarda los libros nuevos, deberas poner un codigo que SAVEAS que los grabe, eso ya es cosa tuya.

Espero te sirva.

Deberás crear un botón y asignarle la macro: Bton_Empezar()
No puedo adjuntar el modulo así que te adjunto el fichero excel con el modulo, pero por si acaso, lo escribo aquí:

Código:
Option Compare Text
Código:
Código:
Código:
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



Un saludo.
Mil gracias!!
 

Temas similares

Arriba