Öncekide31 adet buluyordu buda aynı.
Deneyebilirsiniz.
Private Sub SayfayýHazýrla_Click()
Dim bul As Range, s1 As Worksheet, s2 As Worksheet, s3 As Worksheet, arr2(), dic As Object
Dim arr(), i As Long, son As Long, dogru As Boolean, say As Long, soncomboSayfa As Long
Dim sonKontrolSicil As Long, varmi As Boolean, k As Long
varmi = True
Application.ScreenUpdating = False
If Len(Trim(Me.ComboBox1.Value)) = 0 Then
MsgBox "Sayfa seciniz...", vbCritical, "Safa sec"
Exit Sub
End If
Set dic = CreateObject("Scripting.Dictionary")
Set s1 = ThisWorkbook.Sheets("VERÝ")
Set s2 = ThisWorkbook.Sheets("KONTROL")
Set s3 = ThisWorkbook.Sheets(Me.ComboBox1.Value)
son = s1.Cells(Rows.Count, 1).End(3).Row
soncomboSayfa = s3.Cells(Rows.Count, "Aj").End(3).Row
sonKontrolSicil = s2.Cells(Rows.Count, "F").End(3).Row
If soncomboSayfa < 7 Then soncomboSayfa = 7
If son < 2 Then GoTo son
If sonKontrolSicil < 2 Then
varmi = False
GoTo var
End If
For i = 2 To son
If Not dic.exists(s1.Cells(i, 2).Value + 0) Then dic.Add s1.Cells(i, 2).Value + 0, s1.Cells(i, 2).Value + 0
Next
var:
ReDim arr(1 To son, 1 To 5)
say = 1
On Error Resume Next
s3.Range("A7:AJ" & Rows.Count).UnMerge
s3.Range("A7:AJ" & Rows.Count).ClearContents
s3.Range("A7:AJ" & Rows.Count).Borders.LineStyle = xlNone
On Error GoTo 0
For i = 2 To son
dogru = False
If varmi = True Then
For k = 2 To sonKontrolSicil
If s2.Cells(k, "F").Value <> "" Then
If s2.Cells(k, "F").Value + 0 = dic(s1.Cells(i, 2).Value + 0) Then
dogru = True
GoTo 10
End If
End If
Next
End If
Set bul = s2.Range("D:F").Find(s1.Cells(i, 5).Value, , , 1)
If Not bul Is Nothing Then dogru = True
Set bul = s2.Range("D:F").Find(s1.Cells(i, 6).Value, , , 1)
If Not bul Is Nothing Then dogru = True
10
If dogru = False Then
arr(say, 1) = say
arr(say, 2) = s1.Cells(i, 2).Value + 0
arr(say, 3) = s1.Cells(i, 5).Value
arr(say, 4) = s1.Cells(i, 3).Value
arr(say, 5) = s1.Cells(i, 4).Value
say = say + 1
End If
Next
If say > 1 Then
s3.Range("A7").Resize(say, UBound(arr, 2)).Value = arr
soncomboSayfa = s3.Cells(Rows.Count, 1).End(3).Row
s3.Range("F7:Ai" & soncomboSayfa).Value = 1
s3.Range("F7:AJ" & soncomboSayfa).Borders.LineStyle = 1
ReDim arr2(1 To soncomboSayfa, 1 To 1)
say = 0
For i = 7 To soncomboSayfa
say = say + 1
arr2(say, 1) = WorksheetFunction.Sum(s3.Range(s3.Cells(i, "F"), s3.Cells(i, "Ai")))
Next
s3.Range("AJ7").Resize(soncomboSayfa, 1).Value = arr2
s3.Range("B7:Aj" & soncomboSayfa).Sort s3.Range("B7"), , , , , , , xlNo
End If
son:
Application.ScreenUpdating = True
Set s1 = Nothing: Set s2 = Nothing: Set s3 = Nothing: Set bul = Nothing: Erase arr: Erase arr2: Set dic = Nothing
MsgBox "Bitti", vbInformation, "Bitti"
End Sub