Mejorar macro Copiar datos a hojas según criterios Excel

H o l a:

Envíame tu archivo. Recuerda poner tu nombre de usuario en el asunto del correo.

Hola Dante,

Ya le envié el archivo

Slds

Robert

Te anexo la macro actualizada

Sub CrearHojas()
'Por.Dante Amor
    On Error Resume Next
    Application.ScreenUpdating = False
    Set h1 = Sheets("Hoja1")
    Set h2 = Sheets("PRIN")
    Set h4 = Sheets("LISTA")
    '
    For m = 2 To h4.Range("A" & Rows.Count).End(xlUp).Row
        h1.[C2] = h4.Cells(m, "A")
        h1.Columns("AA:AN").Clear
        u = h1.Range("B" & Rows.Count).End(xlUp).Row
        h1.Range("A3:N" & u).AdvancedFilter Action:=xlFilterCopy, _
            CriteriaRange:=h1.Range("C1:C2"), CopyToRange:=h1.Range("AA3"), Unique:=False
        '
        u2 = h1.Range("AB" & Rows.Count).End(xlUp).Row
        If u2 > 3 Then
            'MsgBox "No existen registros con esa referencia"
            'Exit Sub
            '
            nombre = h1.Range("AC4")
            h2.Copy after:=Sheets(Sheets.Count)
            Set h3 = ActiveSheet
            h3.Name = nombre
            Set b = h1.Columns("B").Find(h1.[C2], lookat:=xlWhole)
            If Not b Is Nothing Then
                h3.[C8] = h1.Cells(b.Row, "B")
                h3.[B10] = h1.Cells(b.Row, "C")
                h3.[D11] = h1.Cells(b.Row, "N")
                h3.[B9] = h1.Cells(b.Row, "M")
            End If
            '
            n = 2
            j = 0
            k = 17
            For i = 4 To u2
                If j = 39 Then
                    h2.Copy after:=Sheets(Sheets.Count)
                    Set h3 = ActiveSheet
                    h3.Name = nombre & " " & n
                    h3.[C8] = h1.Cells(b.Row, "B")
                    h3.[B10] = h1.Cells(b.Row, "C")
                    h3.[D11] = h1.Cells(b.Row, "N")
                    h3.[B9] = h1.Cells(b.Row, "M")
                    '
                    n = n + 1
                    j = 1
                    k = 17
                End If
                h3.Cells(k, "A") = h1.Cells(i, "AJ")
                h3.Cells(k, "B") = h1.Cells(i, "AF")
                h3.Cells(k, "C") = h1.Cells(i, "AG")
                h3.Cells(k, "D") = h1.Cells(i, "AH")
                'h3.Cells(k, "E") = h1.Cells(i, "AD")
                If h1.Cells(i, "AD") = "ENTRADAS" Then
                    h3.Cells(k, "F") = h1.Cells(i, "AE")
                Else
                    h3.Cells(k, "G") = h1.Cells(i, "AE")
                End If
                j = j + 1
                k = k + 1
            Next
        End If
        h1.Columns("AA:AN").Clear
    Next
    Application.ScreenUpdating = True
    MsgBox "Hojas Creadas"
End Sub

':)
'S aludos. D a n t e   A m o r . R ecuerda valorar la respuesta. G racias
':)