Macro para crear un archivo diferente por cada dato existente en cualquier fila de una misma columna

Necesito hacer una macro que cree un archivo que comience por los datos de las celdas de una misma columna. Estas celdas son 2 ó 3 letras/números en cada fila de la columna "B". Pueden ser iguales o diferentes. Por eso necesito que en cada archivo aparezcan las filas que contengas en la columna "B" estos dígitos letras/números. Detrás de estas 2 ó 3 letras/números debe aparecer el texto "_eventos_noviembre_2015.xls". Por ejemplo, "T2R_eventos_noviembre_2015.xls".

Los datos aparecerán en el archivo "eventos.xls" que está en la carpeta con la ruta "L:\Datos". Los archivos creados deben crearse en la carpeta "L:\Resultado".

Muchas gracias por vuestro tiempo y dedicación. Soy nuevo en esto y no sé como hacer la macro.

Respuesta
1

H o l a:

Puedes enviarme un archivo y me marcas en amarillo qué datos se tienen que enviar al nuevo archivo.

Me envías el nuevo archivo de ejemplo en dónde copiaste las celdas en amarillo.

Sal u dos

H o l a:

Te anexo la macro para generar archivos.

También debes cambiar en esta línea de la macro, el texto que vas a utilizar para nombrar los archivos, reemplaza "texto" por lo que desees.

nombre = h2.Cells(i, "A") & "texto"

Sub CrearArchivos()
'Por.Dante Amor
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets(1)
    Set h2 = l1.Sheets(2)
    '
    ruta = l1.Path & "\"
    h2.Cells.Clear
    h1.Columns("B").Copy h2.Columns("A")
    h1.Range("A1") = "Texto"
    h1.Range("B1") = "Codigo"
    h1.Range("D1") = "Codigo"
    u1 = h2.Range("A" & Rows.Count).End(xlUp).Row
    h2.Range("A1:A" & u1).RemoveDuplicates Columns:=1, Header:=xlYes
    u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
    For i = 2 To u2
        If h1.FilterMode Then h1.ShowAllData
        nombre = h2.Cells(i, "A") & "texto"
        h1.[D2] = nombre
        h1.Range("A1:B" & u1).AdvancedFilter Action:=xlFilterInPlace, _
            CriteriaRange:=h1.Range("D1:D2"), Unique:=False
        Set l2 = Workbooks.Add
        Set h3 = l2.Sheets(1)
        h1.Range("A:B").Copy h3.[A1]
        'l2.SaveAs Filename:=ruta & nombre & ".xlsx", FileFormat:=xlOpenXMLWorkbook
        l2.SaveAs Filename:=ruta & nombre & ".xlsx", FileFormat:=xlNormal
        l2.Close
    Next
    MsgBox "Proceso terminado", vbInformation
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas