Dim licznik, koniec As Integer

Dim licznik as integer, koniec As Integer

Application.ScreenUpdating = False

Cells.Select
    Selection.Copy

Sub PodziałPliku()

'--------------------------------------------
'Deklaracja zmiennych
'--------------------------------------------

Dim Polecenie1, Polecenie2, Tytuł1, Tytuł2, Miesiąc, DataRaportu, Raportścieżka As String
Dim wart As String
Dim wyjdz As Integer
Dim licznik, koniec As Integer
Dim kryterium, hasło, nazwa As String

Podział = ActiveWorkbook.Name
    koniec = Cells(1, 6) 'liczba kryterium
'--------------------------------------------
'Otworzenie raportu
'--------------------------------------------

Do
wyjdz = 0
Polecenie1 = "Podaj miesiąc raportu"
Tytuł1 = "Miesiąc"
Miesiąc = InputBox(Polecenie1, Tytuł1, Default)
Polecenie2 = "Podaj datę raportu(RRRRMMDD)"
Tytuł2 = "Data raportu"
DataRaportu = InputBox(Polecenie2, Tytuł2, Default)

Raportścieżka = "I:\" & Miesiąc & "\Raport_" & DataRaportu & ".xlsx"
If FileOrDirExists(Raportścieżka) Then
Workbooks.Open (Raportścieżka)
Else
wart = MsgBox("Brak podanego raportu! Czy szukać jeszcze raz?", vbYesNo)
If wart = 6 Then
wyjdz = 1
End If
End If
Loop While wyjdz = 1

'--------------------------------------------
'Sortowanie
'--------------------------------------------
ActiveWorkbook.Worksheets("Arkusz1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Arkusz1").AutoFilter.Sort.SortFields.Add Key:= _
        Range("C1:C16038"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("Arkusz1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
'--------------------------------------------
'Podział raportu
'--------------------------------------------

For licznik = 2 To koniec

'Tworzenie pliku
    Workbooks(Podział).Activate
    kryterium = Cells(licznik, 1) 'kolejne kryterium zapisane w kolumnie 1
    hasło = Cells(licznik, 2) 'każdy plik ma być zabezpieczony innym hasłem ipod inną nazwą
    nazwa = Cells(licznik, 3)
    
    Workbooks("Raport_" & DataRaportu & ".xlsx").Activate
    ActiveSheet.Range("$A$1:$R$16038").AutoFilter Field:=3, Criteria1:=kryterium, _
        Operator:=xlAnd
    Cells.Select
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs Filename:= _
        "I:\oddziały_zestawienie\" & Miesiąc & "\" & nazwa & ".xls", FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False, Password:=hasło
    ActiveWindow.Close
    

Next licznik

Workbooks("Raport_" & DataRaportu & ".xlsx").Close SaveChanges:=False
MsgBox ("Koniec podziału")
End Sub

Function FileOrDirExists(PathName As String) As Boolean
     'Macro Purpose: Function returns TRUE if the specified file
     ' or folder exists, false if not.
     'PathName : Supports Windows mapped drives or UNC
     ' : Supports Macintosh paths
     'File usage : Provide full file path and extension
     'Folder usage : Provide full folder path
     ' Accepts with/without trailing "\" (Windows)
     ' Accepts with/without trailing ":" (Macintosh)
     
    Dim iTemp As Integer
     
     'Ignore errors to allow for error evaluation
    On Error Resume Next
    iTemp = GetAttr(PathName)
     
     'Check if error exists and set response appropriately
    Select Case Err.Number
    Case Is = 0
        FileOrDirExists = True
    Case Else
        FileOrDirExists = False
    End Select
     
     'Resume error checking
    On Error GoTo 0
End Function