Private Sub Variante12sek()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim Li, wksq, z, ky, lie, s, ze, lastRow
Dim ti
Set Li = CreateObject("Scripting.Dictionary")
Set wksq = ThisWorkbook.ActiveSheet
ti = Timer
With wksq
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For z = 3 To lastRow
lie = UCase(.Cells(z, 1).Text)
If Not Li.Exists(lie) And lie <> "" Then Li.Add lie, lie
Next z
For Each ky In Li.keys
Set wb = Workbooks.Add
.Rows("1:2").Copy wb.Sheets(1).Cells(1, 1)
ze = 3
For z = 3 To lastRow
lie = UCase(.Cells(z, 1).Text)
If lie = ky Then
.Rows(z).Copy wb.Sheets(1).Cells(ze, 1)
ze = ze + 1
End If
Next z
For s = 1 To 43
wb.Sheets(1).Columns(s).Hidden = .Columns(s).Hidden
wb.Sheets(1).Columns(s).ColumnWidth = Columns(s).ColumnWidth
Next s
Rows("2:2").Select
Selection.AutoFilter
wb.Sheets(1).Protect Password:="mdm", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
:=True, AllowInsertingHyperlinks:=True, AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True
Application.DisplayAlerts = False
wb.SaveAs Filename:=ThisWorkbook.Path & "\" & ky & ".xlsx", FileFormat:=51
Application.DisplayAlerts = True
wb.Close False
Next
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox Timer - ti & " sec."
End Sub