- Katılım
- 5 Ağustos 2009
- Mesajlar
- 240
- Excel Vers. ve Dili
- Microsoft Office Excel 2010 32 Bit TR
- Altın Üyelik Bitiş Tarihi
- 02.01.2019
merhaba arkadaşlar iki tane worksheetchange var sayfamda çakışıyor hata veriyor bunları nasıl birleştirebilirim.
Kod1.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim iColor As Integer
Dim İŞLEM
On Error Resume Next
İŞLEM = Application.CutCopyMode
If İŞLEM = xlCopy Or İŞLEM = xlCut Then Exit Sub
iColor = Target.Interior.ColorIndex
If iColor < 0 Then
iColor = 19
Else
iColor = iColor + 5
End If
If iColor = Target.Font.ColorIndex Then iColor = iColor + 1
Cells.FormatConditions.Delete
With Range("A" & Target.Row, Target.Address) 'Rows(Target.Row)
.FormatConditions.Add Type:=2, Formula1:=iInternational 'Or just 1 '"TRUE"
.FormatConditions(1).Interior.ColorIndex = iColor
End With
With Range(Target.Offset(1 - Target.Row, 0).Address & ":" & Target.Offset(-1, 0).Address)
.FormatConditions.Add Type:=2, Formula1:=iInternational 'Or just 1 '"TRUE"
.FormatConditions(1).Interior.ColorIndex = iColor
End With
On Error Resume Next
sat1 = IIf(Target.Row = 1, 1, Target.Row - 1)
sut1 = IIf(Target.Column = 1, 1, Target.Column - 1)
sat2 = Target.Row + 1
sut2 = Target.Column + 1
ilkadres = Target.Address
If Not Intersect(Range(ilkadres), Range(sonadres)) Is Nothing Then Beep
sonadres = Range(Cells(sat1, sut1), Cells(sat2, sut2)).Address
With Target
If .Column <> 3 Then Exit Sub
.ClearComments
.AddComment Text:="" & Cells(.Row, "DE") & " --- " & Cells(.Row, "BP")
'.AddComment Text:="" & Cells(.Row, "DE") & " --- " & Cells(.Row, "BP") & " --- " & Cells(.Row, "DD")
End With
End Sub
Kod2.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
For b = [b655].End(3).Row To 1 Step -1
For c = [c655].End(3).Row To 1 Step -1
For f = [f655].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("b1:b" & b), Cells(b, "b")) > 1 Then Cells(b, "b").ClearContents
If WorksheetFunction.CountIf(Range("c1:c" & c), Cells(c, "c")) > 1 Then Cells(c, "c").ClearContents
If WorksheetFunction.CountIf(Range("f1:f" & f), Cells(f, "f")) > 1 Then Cells(f, "f").ClearContents
Next
Next
Next
End Sub
Kod1.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim iColor As Integer
Dim İŞLEM
On Error Resume Next
İŞLEM = Application.CutCopyMode
If İŞLEM = xlCopy Or İŞLEM = xlCut Then Exit Sub
iColor = Target.Interior.ColorIndex
If iColor < 0 Then
iColor = 19
Else
iColor = iColor + 5
End If
If iColor = Target.Font.ColorIndex Then iColor = iColor + 1
Cells.FormatConditions.Delete
With Range("A" & Target.Row, Target.Address) 'Rows(Target.Row)
.FormatConditions.Add Type:=2, Formula1:=iInternational 'Or just 1 '"TRUE"
.FormatConditions(1).Interior.ColorIndex = iColor
End With
With Range(Target.Offset(1 - Target.Row, 0).Address & ":" & Target.Offset(-1, 0).Address)
.FormatConditions.Add Type:=2, Formula1:=iInternational 'Or just 1 '"TRUE"
.FormatConditions(1).Interior.ColorIndex = iColor
End With
On Error Resume Next
sat1 = IIf(Target.Row = 1, 1, Target.Row - 1)
sut1 = IIf(Target.Column = 1, 1, Target.Column - 1)
sat2 = Target.Row + 1
sut2 = Target.Column + 1
ilkadres = Target.Address
If Not Intersect(Range(ilkadres), Range(sonadres)) Is Nothing Then Beep
sonadres = Range(Cells(sat1, sut1), Cells(sat2, sut2)).Address
With Target
If .Column <> 3 Then Exit Sub
.ClearComments
.AddComment Text:="" & Cells(.Row, "DE") & " --- " & Cells(.Row, "BP")
'.AddComment Text:="" & Cells(.Row, "DE") & " --- " & Cells(.Row, "BP") & " --- " & Cells(.Row, "DD")
End With
End Sub
Kod2.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
For b = [b655].End(3).Row To 1 Step -1
For c = [c655].End(3).Row To 1 Step -1
For f = [f655].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("b1:b" & b), Cells(b, "b")) > 1 Then Cells(b, "b").ClearContents
If WorksheetFunction.CountIf(Range("c1:c" & c), Cells(c, "c")) > 1 Then Cells(c, "c").ClearContents
If WorksheetFunction.CountIf(Range("f1:f" & f), Cells(f, "f")) > 1 Then Cells(f, "f").ClearContents
Next
Next
Next
End Sub
