odchudzenie kodu sumujacego

Witam.

Mianowicie chcialbym prosic o pomoc w odchudzeniu kodu . Kiedys mialem ten kod wykorzystany do innych celow obecnie nie potrzeba mi juz sumowania danych po dacie oraz chyba jesli jest duzo danych makro nie wyrabia.


Sub metal()
If Cells(2, 1).Value > Cells(2, 2).Value Then
MsgBox "Data od musi byś mniejsza od Daty do"
ElseIf IsDate(Cells(2, 1)) = False Or IsDate(Cells(2, 2)) = False Then
 MsgBox "Data od lub Data do jest niepoprawna"
Else
Call ilosc_odpadow(Cells(2, 1).Value, Cells(2, 2).Value)
End If
End Sub
Sub ilosc_odpadow(data_od As Date, data_do As Date)
    Dim koniec As Long
    Dim zakres As Range, zakres_filtr As Range, kom As Range, tabelka As Range
    Dim od_wiersza As Long, od_kolumny As Long, do_kolumny As Long, ost_filtr As Long
    Dim dzial, zm, i As Long, j As Long
    Dim plik As String, sciezka As String
    Application.ScreenUpdating = False
    od_wiersza = 1
    od_kolumny = 1
    do_kolumny = 4
    Set tabelka = Cells(4, 1)
 
 
    koniec = Cells(Rows.Count, tabelka.Column).End(xlUp).Row
    If koniec > 2 Then Range(tabelka, Cells(koniec, tabelka.Column + 1)).ClearContents

sciezka = ActiveWorkbook.Path
  plik = sciezka & "\metalowe.xls"
 If IsFileOpen(plik) Then
 Workbooks("metalowe.xls").Activate
 Else
 Workbooks.Open filename:=plik, ReadOnly:=True
 End If
    koniec = Cells(Rows.Count, 1).End(xlUp).Row
    Set zakres = Range(Cells(od_wiersza, od_kolumny), Cells(koniec, do_kolumny))
    zakres.Select
    Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
                   MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
                   DataOption2:=xlSortNormal

    zakres.AutoFilter Field:=1, Criteria1:=">=" & data_od, Operator:=xlAnd, Criteria2:="<=" & data_do
    ost_filtr = ActiveSheet.Cells(Rows.Count, od_kolumny).End(xlUp).Row
    If ost_filtr > 1 Then
        Set zakres_filtr = ActiveSheet.Range(ActiveSheet.Cells(od_wiersza + 1, 2), ActiveSheet.Cells(ost_filtr, 2).End(xlDown)).SpecialCells(xlVisible)
        dzial = Cells(od_wiersza, od_kolumny + 1)
        zm = Cells(od_wiersza, od_kolumny + 1)
        i = tabelka.Row
        For Each kom In zakres_filtr
            If dzial <> zm Then
                Workbooks("zamówienia.xls").Sheets(14).Cells(i, tabelka.Column) = dzial
                dzial = zm
                i = i + 1
            ElseIf zm = "" Then Exit For
            End If
            zm = kom.Value
        Next
    End If
With Workbooks("zamówienia.xls").Sheets(15)
    For j = tabelka.Row To i - 1
        zakres_filtr.Select
        For Each kom In zakres_filtr
            If kom.Value = .Cells(j, tabelka.Column) Then
                .Cells(j, tabelka.Column + 1) = .Cells(j, tabelka.Column + 1) + Cells(kom.Row, kom.Column + 1).Value
            ElseIf kom.Value = "" Then Exit For
            End If
        Next
    Next j
End With
    zakres.AutoFilter
Workbooks("metalowe.xls").Close SaveChanges:=False
    Application.ScreenUpdating = True
    Workbooks("zamówienia.xls").Sheets(15).Activate
    tabelka.Select
MsgBox "Raport zakończony "

       
End Sub
Function IsFileOpen(filename As String)
       Dim filenum As Integer, errnum As Integer

       On Error Resume Next   ' Turn error checking off.
       filenum = FreeFile()   ' Get a free file number.
       ' Attempt to open the file and lock it.
       Open filename For Input Lock Read As #filenum
       Close filenum          ' Close the file.
       errnum = Err           ' Save the error number that occurred.
       On Error GoTo 0        ' Turn error checking back on.

       ' Check to see which error occurred.
       Select Case errnum

           ' No error occurred.
           ' File is NOT already open by another user.
           Case 0
               IsFileOpen = False

           ' Error number for "Permission Denied."
           ' File is already opened by another user.
           Case 70
               IsFileOpen = False

           ' Another error occurred.
           Case Else
               Error errnum
       End Select
   End Function



i przyklady .

zanotowane.pl

doc.pisz.pl

pdf.pisz.pl

katkaras.opx.pl