hasanyaprak
Altın Üye
- Katılım
- 9 Aralık 2010
- Mesajlar
- 68
- Excel Vers. ve Dili
- İş office 2021 / Ev ofis 2016 64 bit
- Altın Üyelik Bitiş Tarihi
- 13-10-2025
Merhaba Arkadaşlar,
Öncelikle yeni yılın hepimize huzur mutluluk getirmesini dilerim.
Aşağıdaki gibi bir kod kullanıyorum. Çokta güzel yazılmış. Her seferinde sutunu seçmek yerine sabit bir sutuna göre revize etmek için kodda neleri değiştirmeliyim. Yardımınızı rica ederim.
Range("B4:B100").Interior.ColorIndex = xlNone
MsgBox "Renk kaldırıldı!"
Dim xRg As Range
Dim xTxt As String
Dim xCell As Range
Dim xChar As String
Dim xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim i As Long
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("Lütfen işlem yapmak istediğiniz hücre aralığını seçiniz.(Birden fazla aralık seçmek için Ctrl tuşunu kullanabilirsiniz.)", "My To World", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
xCIndex = 2
Set xCol = New Collection
For Each xCell In xRg
On Error Resume Next
xCol.Add xCell, xCell.Text
If Err.Number = 457 Then
xCIndex = xCIndex + 1
Set xCellPre = xCol(xCell.Text)
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
ElseIf Err.Number = 9 Then
MsgBox "Çok fazla yinelenen değer var!", vbCritical, "My To World"
Exit Sub
End If
On Error GoTo 0
Next
Öncelikle yeni yılın hepimize huzur mutluluk getirmesini dilerim.
Aşağıdaki gibi bir kod kullanıyorum. Çokta güzel yazılmış. Her seferinde sutunu seçmek yerine sabit bir sutuna göre revize etmek için kodda neleri değiştirmeliyim. Yardımınızı rica ederim.
Range("B4:B100").Interior.ColorIndex = xlNone
MsgBox "Renk kaldırıldı!"
Dim xRg As Range
Dim xTxt As String
Dim xCell As Range
Dim xChar As String
Dim xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim i As Long
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("Lütfen işlem yapmak istediğiniz hücre aralığını seçiniz.(Birden fazla aralık seçmek için Ctrl tuşunu kullanabilirsiniz.)", "My To World", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
xCIndex = 2
Set xCol = New Collection
For Each xCell In xRg
On Error Resume Next
xCol.Add xCell, xCell.Text
If Err.Number = 457 Then
xCIndex = xCIndex + 1
Set xCellPre = xCol(xCell.Text)
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
ElseIf Err.Number = 9 Then
MsgBox "Çok fazla yinelenen değer var!", vbCritical, "My To World"
Exit Sub
End If
On Error GoTo 0
Next
