¿Cómo modificar la siguiente macro?

Este tema es la continuación de esta pregunta.

1 Respuesta

Respuesta
1

Prueba esto:

Sub listas()

Application.ScreenUpdating = False

Sheets("Generador").Activate
Range("A8:A1000").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("X1"), Unique:=True
Sheets("Generador").Activate
Columns("X:X").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("Generador").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Generador").AutoFilter.Sort.SortFields.Add Key _
:=Range("X1:X31"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets("Generador").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Selection.AutoFilter
Range("Z2").FormulaLocal = "=SI(X2="""","""",CONCATENAR(X2,""("",BUSCARV(X2,$A$9:$B$1000,2,FALSO),"")""))"
'Range("Z2").FormulaLocal = "=SI(X2="""";"""";CONCATENAR(X2;""("";BUSCARV(X2;$A$9:$B$1000;2;FALSO);"")""))"
Range("Z2").Select
Selection.AutoFill Destination:=Range("Z2:Z31")
Sheets.Add
ActiveSheet.Name = "Temp"
Sheets("Generador").Select
Range("A7").Select
Selection.AutoFilter
Range("X1").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select

Set MyRing = Selection
Range("A1").Select
n = 0

For Each Mycell In MyRing
If Mycell.Value = "" Then GoTo fin:
Selection.AutoFilter
ActiveSheet.Range("$A$8").AutoFilter Field:=1, Criteria1:=Mycell
Name = Range("Z1").Offset(1 + n, 0).Value
Range("A9:K1000").Copy Sheets("Temp").Range("A1")
Sheets("Temp").Select
Range("A1:K1000").Copy
Range("A1:K1000").PasteSpecial xlValues
filas = WorksheetFunction.CountA(Range("A1:A1000"))
n = n + 1
J = 1
w = 0
If filas > 13 Then
hojas = Int((filas / 13) + 1)
For I = 1 To hojas
Sheets("FGen").Select
Sheets("FGen").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = Name & "(" & J & ")"
Sheets("Temp").Select
Range(Cells(1 + w, 2), Cells(13 + w, 11)).Copy Sheets(Name & "(" & J & ")").Cells(12, 2)
Total = Total + Sheets(Name & "(" & J & ")").Range("K25").Value
w = w + 13
J = J + 1
If I = hojas Then

Sheets(Sheets.Count).Range("J25").Value = "Total:"
Sheets(Sheets.Count).Range("K25").Value = Total
Total = 0
Else
End If
Next

Else
Sheets("FGen").Select
Sheets("FGen").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = Name
Sheets("Temp").Select
Range("B1:K13").Copy Sheets(Name).Range("B12")
End If

Sheets("Temp").Range("A1:K1000").ClearContents
Sheets("Generador").Select
Selection.AutoFilter
Next

fin:

Application.DisplayAlerts = False
Sheets("Temp").Delete
Sheets("Generador").Select
ActiveSheet.ListObjects("Tgen").Range.AutoFilter Field:=1
Columns("X:Z").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Un saludo

https://www.dropbox.com/s/9299be0fo0nmr01/prueba%20final%204.xlsm?dl=0 

Perfecto, funciono muy bien muchas gracias.

Aprovecho para adjuntar esta pregunta, por si tienes alguna respuesta,

Muchas gracias.

Un Saludo

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas