Scripting Dictionary

[1903emre34@gmail.com]

Merhaba,

Aşağıdaki kodların daha hızlanması için, scripting.dictionary fonksiyonu kullanmak istiyorum.

Private Sub CommandButton1_Click()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Range("a2:m" & Rows.Count).Clear
i = s1.Cells(Rows.Count, "F").End(3).Row
Application.ScreenUpdating = False
For a = 2 To i
If s1.Cells(a, "F") <> "" Then
s = s1.Cells(a, "F").End(xlDown).Row
tpl = Application.Sum(s1.Range("H" & a & ":I" & s))
With s1.Range("F" & a + 1 & ":F" & i)
    Set c = .Find(s1.Cells(a, "F"), LookIn:=xlValues)
    If Not c Is Nothing Then
f = c.Address
 Do
x = s1.Cells(c.Row, "F").End(xlDown).Row + 1
tpl2 = Application.Sum(s1.Range("H" & c.Row & ":I" & x))
If tpl = tpl2 And Val(s1.Range("H" & a)) <> Val(s1.Range("H" & c.Row)) Then
r = s2.Cells(Rows.Count, 2).End(3).Row + 2
s1.Range("A" & a & ":M" & s).Copy
s2.Cells(r, "B").PasteSpecial
s2.Range("A" & r).Value = a
r = s2.Cells(Rows.Count, 2).End(3).Row + 2
s1.Range("A" & c.Row & ":M" & x).Copy
s2.Cells(r, "B").PasteSpecial
s2.Range("A" & r).Value = c.Row
Application.CutCopyMode = False
End If
Set c = .FindNext(c)
If c Is Nothing Then Exit Do
        Loop While Not c Is Nothing And c.Address <> f
    End If
End With
a = s
End If
Next
Application.ScreenUpdating = True
s2.Activate
End Sub

 

[1903emre34@gmail.com]

Konu güncel.

 

[Necdet]

Merhaba,

Kodları anlamak uzun ve zahmetli iş.
Basit örnek dosya hazırlayınız ki daha hızlı destek alabilesiniz.