Sub Kopiranje()
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long, iCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, TitleRow As Long
Application.ScreenUpdating = False
vCol = 1
Set ws = Sheets("Sheet1")
vTitles = "A1:Z1"
TitleRow = Range(vTitles).Cells(1).Row
LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
iCol = ws.Columns.Count
ws.Cells(1, iCol) = "key"
For Itm = TitleRow + 1 To LR
On Error Resume Next
If ws.Cells(Itm, vCol) <> "" And Application.WorksheetFunction _
.Match(ws.Cells(Itm, vCol), ws.Columns(iCol), 0) = 0 Then
ws.Cells(ws.Rows.Count, iCol).End(xlUp).Offset(1) = ws.Cells(Itm, vCol)
End If
Next Itm
ws.Columns(iCol).Sort Key1:=ws.Cells(2, iCol), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
MyArr = Application.WorksheetFunction.Transpose _
(ws.Columns(iCol).SpecialCells(xlCellTypeConstants))
ws.Columns(iCol).Clear
ws.Range(vTitles).AutoFilter
For Itm = 2 To UBound(MyArr)
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=CStr(MyArr(Itm))
If Not Evaluate("=ISREF('" & CStr(MyArr(Itm)) & "'!A1)") Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CStr(MyArr(Itm))
Else
Sheets(CStr(MyArr(Itm))).Move After:=Sheets(Sheets.Count)
Sheets(CStr(MyArr(Itm))).Cells.Clear
End If
ws.Range("A" & TitleRow & ":A" & LR).EntireRow.Copy _
Sheets(CStr(MyArr(Itm))).Range("A1")
ws.Range(vTitles).AutoFilter Field:=vCol
MyCount = MyCount + Sheets(CStr(MyArr(Itm))).Range("A" & Rows.Count) _
.End(xlUp).Row - Range(vTitles).Rows.Count
Sheets(CStr(MyArr(Itm))).Columns.AutoFit
Next Itm
ws.AutoFilterMode = False
ws.Activate
MsgBox "Broj redova sa podacima: " & (LR - TitleRow) & vbLf & "Redova kopirano na druge listove: " _
& MyCount & vbLf
Application.ScreenUpdating = True
End Sub