Excel kod uyarlama

[excelience]

MERHABA ARKADASLAR BU YAZACAGIM KODU ASAGIDAKİ KODLARIN ALTINA YAZINCA HATA VERİYOR BU KODU ASAGIDA YAZILI KODA UYARLARMISINIZ ŞİMDİDEN ÇOK TEŞEKKÜRLER
Private Sub Worksheet_Deactivate()
Call gönder
End Sub
Sub gönder()
Application.ScreenUpdating = False
On Error Resume Next
Sheets("veri").Range("d5:e65536").ClearContents
Set s1 = ThisWorkbook.Worksheets("CARİGENEL")
Set s2 = ThisWorkbook.Worksheets("DÖKÜM")
sat = 5
For i = 8 To s1.Range("h65536").End(xlUp).Row

If WorksheetFunction.CountIf(Sheets("CARİGENEL").Range("m2:m200"), Sheets("CARİGENEL").Cells(i, "h")) >= 1 Then
s2.Cells(sat, "d") = s1.Cells(i, "f")
sat = sat + 1
End If

If WorksheetFunction.CountIf(Sheets("CARİGENEL").Range("n2:n200"), Sheets("CARİGENEL").Cells(i, "h")) >= 1 Then
s2.Cells(sat, "e") = s1.Cells(i, "f")
sat = sat + 1
End If

Next i
Application.ScreenUpdating = True
End Sub


YUKARIDA Kİ KOD KENDİ BAŞINA ÇALISIYOR FAKAT BASKA BİR EXCEL CALISMASINDA Kİ SAYFADA BU KODLARIN ALTINA YAPIŞTIRINCA HATA VERİYOR YARDIMCI OLURSANIZ COK MUTLU OLURUM EMEKLERİNİZ İÇİN TEŞŞEKÜRLER


----------------------------------------------------------------------------------
Option Explicit
Sub OZET1()
Dim S1 As Worksheet, S2 As Worksheet, Son As Long, X As Long, Say As Long
Dim Veri As Variant, Liste As Variant, Zaman As Double, Kriter As String
Zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Set S1 = Sheets("CARİGENEL")
Set S2 = Sheets("RAPOR")
S2.Range("B8:I" & S2.Rows.Count).ClearContents
Son = S1.Cells(S1.Rows.Count, 3).End(3).Row
Veri = S1.Range("C8" & Son).Value
ReDim Liste(1 To UBound(Veri, 1), 1 To 2)
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For X = 1 To UBound(Veri, 1)
If Veri(X, 1) <> "" Then
Kriter = Veri(X, 1)
If Not IsEmpty(Kriter) Then
If Not .Exists(Kriter) Then
Say = Say + 1
.Add Kriter, Say
Liste(Say, 1) = Veri(X, 1)
End If
On Error Resume Next
Liste(.Item(Kriter), 2) = Liste(.Item(Kriter), 2) + Veri(X, 2)
On Error GoTo 0
End If
End If
Next
End With
S2.Range("B8").Resize(Say, 2).Value = Liste
Set S1 = Nothing
Set S2 = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Call OZET2
Call OZET3
Call OZET4
Call OZET5
MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.000") & " Saniye", vbInformation, "Bilgilendirme"
End Sub
Sub OZET2()
Dim S1 As Worksheet, S2 As Worksheet, Son As Long, X As Long, Say As Long
Dim Veri As Variant, Liste As Variant, Zaman As Double, Kriter As String
Zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Set S1 = Sheets("CARİGENEL")
Set S2 = Sheets("RAPOR")

Son = S1.Cells(S1.Rows.Count, 6).End(3).Row
Veri = S1.Range("F8:G" & Son).Value
ReDim Liste(1 To UBound(Veri, 1), 1 To 2)
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For X = 1 To UBound(Veri, 1)
If Veri(X, 2) <> "" Then
Kriter = Veri(X, 2)
If Not IsEmpty(Kriter) Then
If Not .Exists(Kriter) Then
Say = Say + 1
.Add Kriter, Say
Liste(Say, 1) = Veri(X, 2)
End If
On Error Resume Next
Liste(.Item(Kriter), 2) = Liste(.Item(Kriter), 2) + Veri(X, 1)
On Error GoTo 0
End If
End If
Next
End With
S2.Range("D8").Resize(Say, 2).Value = Liste
Set S1 = Nothing
Set S2 = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub
Sub OZET3()
Dim S1 As Worksheet, S2 As Worksheet, Son As Long, X As Long, Say As Long
Dim Veri As Variant, Liste As Variant, Zaman As Double, Kriter As String
Zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Set S1 = Sheets("CARİGENEL")
Set S2 = Sheets("RAPOR")

Son = S1.Cells(S1.Rows.Count, 6).End(3).Row
Veri = S1.Range("F8:H" & Son).Value
ReDim Liste(1 To UBound(Veri, 1), 1 To 2)
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For X = 1 To UBound(Veri, 1)
If Veri(X, 3) <> "" Then
Kriter = Veri(X, 3)
If Not IsEmpty(Kriter) Then
If Not .Exists(Kriter) Then
Say = Say + 1
.Add Kriter, Say
Liste(Say, 1) = Veri(X, 3)
End If
On Error Resume Next
Liste(.Item(Kriter), 2) = Liste(.Item(Kriter), 2) + Veri(X, 1)
On Error GoTo 0
End If
End If
Next
End With
S2.Range("F8").Resize(Say, 2).Value = Liste
Set S1 = Nothing
Set S2 = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub


Sub OZET4()
Dim S1 As Worksheet, S2 As Worksheet, Son As Long, X As Long, Say As Long
Dim Veri As Variant, Liste As Variant, Zaman As Double, Kriter As String
Zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Set S1 = Sheets("CARİGENEL")
Set S2 = Sheets("RAPOR")

Son = S1.Cells(S1.Rows.Count, 6).End(3).Row
Veri = S1.Range("F8:I" & Son).Value
ReDim Liste(1 To UBound(Veri, 1), 1 To 2)
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For X = 1 To UBound(Veri, 1)
If Veri(X, 4) <> "" Then
Kriter = Veri(X, 4)
If Not IsEmpty(Kriter) Then
If Not .Exists(Kriter) Then
Say = Say + 1
.Add Kriter, Say
Liste(Say, 1) = Veri(X, 4)
End If
On Error Resume Next
Liste(.Item(Kriter), 2) = Liste(.Item(Kriter), 2) + Veri(X, 1)
On Error GoTo 0
End If
End If
Next
End With
S2.Range("H8").Resize(Say, 2).Value = Liste
Set S1 = Nothing
Set S2 = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub


Sub OZET5()
Dim S1 As Worksheet, S2 As Worksheet, Son As Long, X As Long, Say As Long
Dim Veri As Variant, Liste As Variant, Zaman As Double, Kriter As String
Zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Set S1 = Sheets("CARİGENEL")
Set S2 = Sheets("RAPOR")

Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
Veri = S1.Range("B8:G" & Son).Value
ReDim Liste(1 To UBound(Veri, 1), 1 To 3)
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For X = 1 To UBound(Veri, 1)
If Veri(X, 1) <> "" Then
Kriter = Veri(X, 1) & ":" & Veri(X, 6)
If Not IsEmpty(Kriter) Then
If Not .Exists(Kriter) Then
Say = Say + 1
.Add Kriter, Say
Liste(Say, 1) = Veri(X, 1)
Liste(Say, 2) = Veri(X, 6)
End If
On Error Resume Next
Liste(.Item(Kriter), 3) = Liste(.Item(Kriter), 3) + Veri(X, 5)
On Error GoTo 0
End If
End If
Next
End With
S2.Range("J8").Resize(Say, 3).Value = Liste
Set S1 = Nothing
Set S2 = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub
Private Sub Worksheet_Deactivate()
Call gönder
End Sub
Sub gönder()
Application.ScreenUpdating = False
On Error Resume Next
Sheets("veri").Range("d8:e65536").ClearContents
Set S2 = ThisWorkbook.Worksheets("carigenel")
Set S5 = ThisWorkbook.Worksheets("DÖKÜM")
sat = 5
For i = 8 To S2.Range("h65536").End(xlUp).Row

If WorksheetFunction.CountIf(Sheets("carigenel").Range("m2:m200"), Sheets("carigenel").Cells(i, "h")) >= 1 Then
S5.Cells(sat, "d") = S2.Cells(i, "f")
sat = sat + 1
End If

If WorksheetFunction.CountIf(Sheets("carigenel").Range("n2:n200"), Sheets("carigenel").Cells(i, "h")) >= 1 Then
S5.Cells(sat, "e") = S2.Cells(i, "f")
sat = sat + 1
End If

Next i
Application.ScreenUpdating = True
End Sub

 

[BedriA]

Option Explicit

Şunu silip bir deneyin.
Ancak başka bir koda zararı olur mu emin değilim.

 

[excelience]

Option Explicit

Şunu silip bir deneyin.
Ancak başka bir koda zararı olur mu emin değilim.

HOCAM SÜPERSİNİZ ÇOK TEŞEKKÜRLER :bravo::bravo::bravo::bravo::bravo: