Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1584to1588
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA auf Bereich ändern

VBA auf Bereich ändern
09.10.2017 14:55:45
Blue
Servus Forumgemeinde,
ich weiß einige im Forum ändern ungern fremde Makros um, aber ich komme leider nicht alleine weiter.
Daher hoffe ich das jemand von euch mit folgendes Makro was auf Spalte C bezogen ist.
Auf den Bereich B4 bis U12 ändern könnte.
Sub Doppelte_markieren_Spalte_C()
Dim lngZeile As Long
Dim lngEnde As Long
Dim strValue As String
Dim objDupList As Object
Dim arrFarben As Variant
Dim intFarben As Integer
arrFarben = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
Set objDupList = CreateObject("Scripting.Dictionary")
lngEnde = Cells(Rows.Count, 3).End(xlUp).Row
Columns("C:C").Interior.ColorIndex = xlNone
For lngZeile = 1 To lngEnde
strValue = Cells(lngZeile, "C").Text
If strValue  "" Then
If Application.CountIf(Range("C1:C" & lngEnde), strValue) > 1 Then
If objDupList.Exists(strValue) Then
Cells(lngZeile, "C").Interior.ColorIndex = objDupList.Item(strValue)
Else
Cells(lngZeile, "C").Interior.ColorIndex = arrFarben(intFarben)
objDupList.Add strValue, arrFarben(intFarben)
intFarben = intFarben + 1
If intFarben > UBound(arrFarben) Then intFarben = 0
End If
End If
End If
Next
End Sub

mfg Blue Bird

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA auf Bereich ändern
09.10.2017 15:08:00
yummi
Hallo Blue Bird,
mach es so, dann brauchst du es nciht jedesmal anpassen ;-)

Sub Test()
Dim wks As Worksheet
Set wks = ThisWorkbook.Sheets("Tabelle1")
Call Doppelte_markieren_Bereich(wks, "B4:U12")
End Sub
Function Doppelte_markieren_Bereich(ByVal wks As Worksheet, ByVal rngstr As String)
Dim strValue As String
Dim rng As Range
Dim objDupList As Object
Dim arrFarben As Variant
Dim intFarben As Integer
Dim zelle As Object
arrFarben = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
Set objDupList = CreateObject("Scripting.Dictionary")
wks.Range(rngstr).Interior.ColorIndex = xlNone
Set rng = Range(rngstr)
For Each zelle In rng
strValue = zelle.Value
If strValue  "" Then
If Application.CountIf(Range(rngstr), strValue) > 1 Then
If objDupList.Exists(strValue) Then
zelle.Interior.ColorIndex = objDupList.Item(strValue)
Else
zelle.Interior.ColorIndex = arrFarben(intFarben)
objDupList.Add strValue, arrFarben(intFarben)
intFarben = intFarben + 1
If intFarben > UBound(arrFarben) Then intFarben = 0
End If
End If
End If
Next
End Function
Gruß
yummi
Anzeige
Danke
09.10.2017 15:10:38
Blue
Danke yummi,
passt perfekt!
mfg Blue Bird
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige
Archiv - Verwandte Themen