Kaydet sorunu

[polis-53]

merhaba arkadaşlar aşağıdaki kodu formdan aldım ve kendime uyarladım fakat kaydet butonuma bastığımda uzun süre bekledikten sonra kaydediyor nerde bir eksik yapıyorum bulamadım bi yardım ederseniz çok sevineceğim. kalın sağlıcakla iyi çalışmalar.


Private Sub CommandButton1_Click()
On Error Resume Next

Set S1 = ThisWorkbook.Worksheets("OCAK")

For Each bak In Range("b1:b" & WorksheetFunction.CountA(Range("a1:a65536")))
SAra = S1.Range(bak.Offset(0, 1).Address).Value
If Ara = ComboBox6 And SAra = TextBox2 Then
Exit Sub
End If
Next
Sonsatir = S1.Cells(65536, "A").End(3).Row
sno = Val(S1.Cells(Sonsatir, "A").Value)
If sno = 0 Then
sno = 1
S1.Cells(Sonsatir + 1, "A").Value = sno
ElseIf sno > 0 Then
S1.Cells(Sonsatir + 1, "A").Value = sno + 1
End If
S1.Cells(Sonsatir + 1, "B") = DTPicker1
S1.Cells(Sonsatir + 1, "C") = ComboBox6
S1.Cells(Sonsatir + 1, "D") = TextBox2.Text
S1.Cells(Sonsatir + 1, "E") = CDbl(TextBox3.Text)
S1.Range("A2:F65536").Select
Selection.Sort key1:=S1.Range("A2"), order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
say = S1.Cells(65536, "A").End(2).Row
ListView1.ListItems.Clear
For i = 2 To say
Set liste1 = Me.ListView1.ListItems.Add(, , S1.Cells(i, "A").Value)
liste1.SubItems(1) = S1.Cells(i, "B").Value
liste1.SubItems(2) = S1.Cells(i, "C").Value
liste1.SubItems(3) = S1.Cells(i, "D").Value
liste1.SubItems(4) = S1.Cells(i, "E").Value

Next i
ListView1.FullRowSelect = True
ListView1.Gridlines = True
MsgBox ("Verileriniz Kayıt edilmiştir."), vbCritical, ("Veri Kayıt")

Dim lvwItm As ListItem
Set lvwItm = ListView1.FindItem(ComboBox6.Text, , , lvwPartial)

n = lvwItm.Index
ListView1.ListItems.Selected = True
ListView1.SelectedItem.EnsureVisible
ListView1.DropHighlight = ListView1.ListItems
For tem = 1 To 6
Controls("textbox" & tem) = Empty
Next
TextBox20.Text = ""
End Sub