makro düzenleme

[DR MOBİL]

sayın excel web uzmanları formda yaptığım aramalar sonunda bulduğum bir dosyayı kendime uyarlamaya çalıştım fakat başaramadım sizden istediğim aşağıdaki kodlar içinde kırmızı ile işaretlenmiş olan kodların sayfada işlem görmemesi yani kodları istemiyorum onları çıkartmaya çalıştım ama bu sefer diğer kodlar çalışmadı diğer kodların aynen görevlerine devam etsini istiyorum lütfen bana bu konuda yardımcı olumusunuz
KODLAR:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim deg As String, adres As String, formul As String
Dim formul_adres_1 As String, formul_adres_2 As String
Dim Sd As Worksheet, sut As Byte

If Cells(Target.Row, "ı") = "A" Then Cells(Target.Row, "d").Font.ColorIndex = 6
If Cells(Target.Row, "ı") = "A" Then Cells(Target.Row, "d").Interior.ColorIndex = 3
If Cells(Target.Row, "ı") = "P" Then Cells(Target.Row, "d").Font.ColorIndex = 3
If Cells(Target.Row, "g").Interior.ColorIndex = 3 Then Cells(Target.Row, "g").Font.ColorIndex = 2
If Cells(Target.Row, "f").Interior.ColorIndex = 3 Then Cells(Target.Row, "f").Font.ColorIndex = 2
If Cells(Target.Row, "f").Interior.ColorIndex = 1 Then Cells(Target.Row, "f").Font.ColorIndex = 2
If Cells(Target.Row, "g").Interior.ColorIndex = 1 Then Cells(Target.Row, "g").Font.ColorIndex = 2
If Cells(Target.Row, "f").Interior.ColorIndex = 4 Then Cells(Target.Row, "f").Font.ColorIndex = 1
If Cells(Target.Row, "g").Interior.ColorIndex = 4 Then Cells(Target.Row, "g").Font.ColorIndex = 1
If Cells(Target.Row, "g").Interior.ColorIndex = 6 Then Cells(Target.Row, "g").Font.ColorIndex = 1
If Cells(Target.Row, "f").Interior.ColorIndex = 6 Then Cells(Target.Row, "f").Font.ColorIndex = 1
If Cells(Target.Row, "f").Interior.ColorIndex = 8 Then Cells(Target.Row, "f").Font.ColorIndex = 1
If Cells(Target.Row, "g").Interior.ColorIndex = 8 Then Cells(Target.Row, "g").Font.ColorIndex = 1
If Cells(Target.Row, "g").Interior.ColorIndex = 26 Then Cells(Target.Row, "g").Font.ColorIndex = 1
If Cells(Target.Row, "f").Interior.ColorIndex = 26 Then Cells(Target.Row, "f").Font.ColorIndex = 1



If Intersect(Target, Range("C:C,E:E,F:F,I:I,K:K,M:M")) Is Nothing Then Exit Sub
If Selection.Cells.Count > 1 Then Exit Sub

Set Sd = Sheets("DATA")
sut = WorksheetFunction.Choose(Target.Column, _
1, 1, 4, 1, 2, 1, 1, 1, 3, 1, 5, 1, 6)

If Target.Column = 6 Then

On Error Resume Next
deg = UCase(Replace(Replace(Target.Value, "ı", "I"), "i", "İ"))
adres = "f" & Target.Row & ":g" & Target.Row
Range(adres).Interior.ColorIndex = xlNone
Target.Interior.ColorIndex = xlNone
Target.Offset(0, 1).ClearContents
formul_adres_1 = "c2:c" & Target.Row
formul_adres_2 = "f2:f" & Target.Row
formul = "=SUMPRODUCT((YEAR(" & formul_adres_1 & ")=YEAR(" & "c" & Target.Row & "))*(" & formul_adres_2 & "=" & Target.Address & "))"

Sd.Cells(Target.Row, sut) = Target.Value

If deg = "1" Then
Range(adres).Interior.ColorIndex = 4
Target.Offset(0, 1) = Evaluate(formul)
ElseIf deg = "Z" Then
Range(adres).Interior.ColorIndex = 3
Target.Offset(0, 1) = Evaluate(formul)
ElseIf deg = "3" Then
Range(adres).Interior.ColorIndex = 6
Target.Offset(0, 1) = Evaluate(formul)
ElseIf deg = "4" Then
Range(adres).Interior.ColorIndex = 1
Target.Offset(0, 1) = Evaluate(formul)
ElseIf deg = "5" Then
Range(adres).Interior.ColorIndex = 8
Target.Offset(0, 1) = Evaluate(formul)
ElseIf deg = "G" Then
Range(adres).Interior.ColorIndex = 7
Target.Offset(0, 1) = Evaluate(formul)
End If
Else
Sd.Cells(Target.Row, sut) = Target.Value
End If
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
If Intersect(Target, Range("j2:j" & [j65536].End(3).Row)) Is Nothing Then GoTo 10
a = Application.WorksheetFunction.Match(Target.Value, Sheets("ICD_10").Range("a:a"), 0)
Application.GoTo ActiveWorkbook.Sheets("ICD_10").Cells(a, "a")
10:
If Intersect(Target, Range("Q:Q")) Is Nothing Then Exit Sub
If Target = "" Then Exit Sub
Cancel = True
Set ds = CreateObject("Scripting.FileSystemObject")
yol = "d:\d-belgeler\epikriz"
Do
If ds.GetFolder(yol).subfolders.Count > 0 Then
For Each kls In ds.GetFolder(yol).subfolders
klslst = klslst & "{" & kls
Next
End If
X = X + 1
deg = Split(klslst, "{")
yol = deg(X)

dosya = Dir$(yol & "\" & Target & ".*")
Do While dosya <> ""
CreateObject("Shell.Application").Open yol & "\" & dosya
Exit Sub

dosya = Dir$()
Loop

Loop While UBound(deg) <> X
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("j2:j" & [j65536].End(3).Row)) Is Nothing Then Exit Sub
Dim s1 As Worksheet
Set s1 = Sheets("ICD_10")
On Error GoTo son
sat = Application.WorksheetFunction.Match(Target.Value, s1.Range("a:a"), 0)
alt = sat + 1
Target.ClearComments
For i = sat To alt
If s1.Cells(i + 1, "a") <> "" Then
yrm = yrm & " " & s1.Cells(i, "b") & " " & s1.Cells(i, "c")
Exit For
Else
If s1.Cells(i, "b") = "" Then Exit For
yrm = yrm & " " & s1.Cells(i, "b") & " " & s1.Cells(i, "c")
alt = alt + 1
End If
Next i

Target.AddComment Text:=yrm
Target.Comment.Shape.TextFrame.AutoSize = True
son:
Set s1 = Nothing
End Sub