Für mehrere Zellen änderst du den Code:

.Range(Cells(I, 1), Cells(I + J - 1, 1)).Interior.Color = RGB(171, 171, 171)

wird

.Range(Cells(I, 1), Cells(I + J - 1, n)).Interior.Color = RGB(171, 171, 171)

Wobei du n durch die Anzahl der Spalten ersetzt, die gefärnt werden sollen

Hier ein Code, der wechselseitig die gleichen Zellen färbt:

Sub srtDoubleMark()
Dim I As Long
Dim J As Long
Dim dblColorFlipFlop As Long

dblColorFlipFlop = 2 'vorbelegen des FlipFlops
' von Zelle A1 bis Zelle A (bis genutztes Maximum)
For I = 1 To ActiveSheet.Range("A:A").SpecialCells(xlCellTypeLastCell).Row
    'wenn Zell emit nachfolgender Zelle gleich, dann
    If Cells(I, 1) = Cells(I + 1, 1) Then
        'Länge des Bereiches vorfestlegen
        J = 2
        ' FlipFlop schalten
        dblColorFlipFlop = 3 - dblColorFlipFlop
        ' Solange wie die nachfolgende Zelle immer noch gleich ist
        Do While Cells(I + J) = Cells(I, 1)
            'Den Bereich der Gleichen erweitern
            J = J + 1
        Loop
         ' Nun färben, je nach Stand des FlipFlop
         With ActiveSheet
            If dblColorFlipFlop = 1 Then
                .Range(Cells(I, 1), Cells(I + J - 1, 1)).Interior.Color = RGB(171, 171, 171)
            Else
                .Range(Cells(I, 1), Cells(I + J - 1, 1)).Interior.Color = RGB(140, 140, 140)
            End If
        End With
    End If
Next I
End Sub

Achtung, bis Excel 2003 kann man bei RGB nur bestimmte Werte benutzen. Erst ab Excel 2010 ist alles möglich.

Statt 
 Interior.Color = RGB( …) kann man auch sagen 
 Interior.Colorindex  = 16

Ganzzahlig, von 1 bis 57  möglich.

Zum Ermitteln der möglichen Farben noch zwei Codes:

Sub srtFarbTest1()
Dim I As Integer
For I = 255 To 5 Step -1
    Cells(256 - I, 1) = I
    Cells(256 - I, 2).Interior.Color = RGB(I, I, I)
Next I
End Sub

Und Code drei

Sub srtFarbTest2()
Dim I As Integer
For I = 1 To 57
    Cells(I, 3) = I
    Cells(I, 4).Interior.ColorIndex = I
Next I

End Sub

Hoffe es hilft

Und für den Fall, dass es tatsächlich ohne Anhang sein muss , kommt hier der Code.

Allerdings werden außer Absatzmarken keine weiteren Formatierungsmerkmale übertragen. Andere Schrift oder -größe oder Tabellen oder Unterstriche... fallen weg, bzw werden durch kryptische Zeichen ersetzt. Musst Du ausprobieren: Setz vor das .Send ein Hochkomma und entferne es in der Zeile davor bei .Display, dann kannst Du die Mail betrachten, ohne sie zu senden.

Zudem habe ich die Schleife angepasst, sie liest jetzt nicht eine feste Anzahl Empfänger ein, sondern nur bis zur letzten benutzten Zeile.

Sub Mail_direct()
Dim obj_wdApp As Word.Application
Dim obj_wdDoc As Word.Document
Dim strDocName As String
Dim strMessage
Dim MyOutApp As Object, MyMessage As Object
Dim i As Long

'eine Wordumgebung anbinden
Set obj_wdApp = CreateObject("Word.Application")
'die .Doc öffnen (Pfad & Namen anpassen!)
strDocName = "D:\!Privat\Lustige_Preise.doc"

Set obj_wdDoc = obj_wdApp.Documents.Add(Template:=strDocName)
'allerdings Fenster auf Taskleite verkleinern
obj_wdApp.WindowState = wdWindowStateMinimize
'Sichtbar machen (in die Taskleiste)
obj_wdApp.Visible = True
With obj_wdApp
  ' im Word-Doc an den Anfang gehen     
 .Selection.HomeKey Unit:=wdStory
 ' Das ganze Doc auswählen      
 .Selection.WholeStory
  ' Die Auswahl in eine Variable kopieren
  strMessage = .Selection.FormattedText
  'oder strMessage = .Selection.Text  
  'ist Wurst, da keine Formatierungen übertragen werden
End With

'Start der Sendeschleife an alle Empfänger
For i = 1 To ActiveSheet.Range("A:A").SpecialCells(xlCellTypeLastCell).Row
    Set MyOutApp = CreateObject("Outlook.Application")
    Set MyMessage = MyOutApp.CreateItem(0)
    With MyMessage
        'Die Empfänger stehen in Spalte A ab Zeile 1
        .To = Cells(i, 1) 'E-Mail Adresse
        'Der Betreff in Spalte B
        .Subject = Cells(i, 2) '"Betreffzeile"
        'Der zu sendende Text in Spalte C
        'Maximal 1024 Zeichen
        'Der Text wird ohne Formatierung übernommen
        .Body = strMessage
        'Hier wird die Mail angezeigt
''        .Display
        'Hier wird die Mail gleich in den Postausgang gelegt
        .Send
    End With


    'Die .doc aus Excel-Sitzung entfernen
    Set obj_wdDoc = Nothing
    'die Word-Instanz aus Excel entfernen (Sonst bleiben Reste in der Taskliste!)
    Set obj_wdApp = Nothing
    'Objectvariablen leeren
    Set MyOutApp = Nothing 'CreateObject("Outlook.Application")
    Set MyMessage = Nothing 'MyOutApp.CreateItem(0)
    'Sendepause einschalten
    'Outlook kann die Aufträge nicht schnell genug verarbeiten
    Application.Wait (Now + TimeValue("0:00:05"))

Next i
End Sub

Hoffe es hilft

Also, mit VBA lässt sich kein formatierter Text übertragen!

Da bleibt Dir nur, den Text als Word-(pdf-)Dokument anzuhängen und in Spalte C zu schreiben:

Bitte lesen Sie die Nachricht im angefügten Word-Dokument
Mit freundlichen Grüßen
Paule_VBA
Die Absatzmarken bekommst Du in Excel in die Zelle, indem Du  Alt festhältst und Enter drückst

Und hinter .Body = Cells(i, 3) fügst Du ein:

    'hier wird die Word-Datei angehängt
    .attachments.Add "D:\Privat\Meine_Datei.doc"

Ist doch auch ein Ansatz.

Das "Vom Vater zum Bräutigam führen" ist ausschließlich ein blöder amerikanischer (Film-) Brauch.

Und wenn Du Wert auf eine feierliche Hochzeit legt, kann man das Standesamt getrost vergessen (ich bin selbst ausgebildeter Standesbeanter, dort aber nicht mehr tätig, habe gerade drei Eheschließungen -eigne Kinder, Cousine- hautnah im Standesamt erlebt). So richtig feierlich ist es halt nur mit einem Traugottesdienst, egal ob kath. oder ev.

Wenn du allerdings jeden Streit vermeiden willst, heirate nur standesamtlich, ohne Vorankündigung bei den Eltern, Verwandten und Freunden. Heutzutage brauchst Du nicht mal mehr die berühmten Trauzeugen: das künftige Ehepaar steht ganz in trauter Zweisamkeit (allein) vor dem Standesbeamten.

Das ganze kurz und knapp, anschließend für drei Wochen in die Flitterwochen und am ersten Tag dort die Karten "Wir haben geheiratet" versenden. Dann haben sich nach den 20 Tagen die Gemühter schon etwas beruhigt.

Und egal was Dir die anderen Ratgeber hier sagen: ich finde es richtig und gut, wenn Du Dir jetzt schon Gedanken darum machst. So hast Du Zeit, alle Möglichkeiten theoretisch mit Deinen Verwandten mal durchzukauen.

Ich wünsche Dir jedenfalls viel Glück und einen tollen Partner für viele Ehejahre (Ich bin selber seit 38 Jahren verheiratet und es knistert noch wie am Anfang)

Wie maximilianus schon schreibt, kann man zusätzlich zu Excel eine Instanz von Word öffnen, dort ein Dokument (ggf. nur einen Teil) kopieren und dann bei Body einfügen:

Body  = "Dies ist der Text, der als Nachricht verschickt wird"
'oder
Body = strMeineVariable

Um dir weiter zu helfen, müssen wir hier also wissen, ist es ein ganzes Doc, nur immer der selbe Teil eines Doc, ein Doc mit aneinander gereihten Textteilen für verschiedene Empfänger.....

Wie stelle ich im Doc fest, welchen Teil ich kopieren soll (Absatz, Zelle eine Tabelle, Seite, Zeile, .............)?

usw.

Ob dabei auch alle Formatierungen übertragen werden, kann ich ohne Versuch nicht sagen, aber hier zu Hause läuft kein Outlook, nur auf Arbeit. Ich gehe eher davon aus, dasss bis auf die Absatzmarken alle Formatierungen entfernt werden.

Ohne deinen Code, der die Färbung durchführt kann ich hier schlecht Tipps geben. Und anderen wird es genauso gehen.

Bitte achte darauf, dass Code auch als Code markiert wird:

Code-Text mit der Maus markieren und Strg-K drücken oder die 5. Schaltfläche oben über dem Editor.

@Maximilianus7: Es geht natürlich auch ohne das ungeliebte Select (Bildschirmflackern):

Sub Visible_Only()
'Nur sichtbare Zellen eines Bereiches bearbeiten
Dim CheckRange As Range
Dim CheckCell As Range
Dim RangeVisible As Range

'Bereich festlegen
Set CheckRange = Range("A1:A28")


'Nur die sichtbaren wählen
Set RangeVisible = CheckRange.SpecialCells(xlCellTypeVisible)

'Nun bearbeiten
For Each CheckCell In RangeVisible
    Cells(CheckCell, 2) = "A"  ' beispielhaft!! setzt ein A neben die sichtbare Zelle in A

    ' CheckCell.row liefert die row number
Next CheckCell
End Sub

@Suboptimierer:

Aber ich habe ich jetzt die Lösung gefunden:

Das generelle Click-Ereignis für alle Labels ist jetzt eine Function:

Function Displayclicked(strCallingLabel As String)

     Me.Controls(strCallingLabel).ForeColor = clrRed
     Me.Controls(strCallingLabel).FontWeight = 600
     Me.Controls(strCallingLabel).ControlTipText = "Schon gewählt"
    'und so weiter
End Function    

Die Function rufe ich beim Click-Ereignis des einzelnen Labels auf und übergebe ihr den Namen des Labels

Damit ich das nicht manuell machen muss, habe ich eine einmalige Prozedur im Modul geschrieben:

Sub umbenennen()
Dim intRow As Integer
Dim intColumn As Integer
Dim strControlName As String

DoCmd.OpenForm "BingoTafel_Beamer", acDesign, , , acFormEdit, acWindowNormal
 
'jetzt Klickereignis füllen
For intRow = 1 To 10
    For intColumn = 1 To 10
        strControlName = "lblNumber" & Format(intRow, "00") & Format(intColumn, "00")
       Forms!BingoTafel_Beamer.Controls(strControlName).OnClick = "= DisplayMonth(" & Chr(34) & strControlName & Chr(34) & ")"
    Next
Next
    DoCmd.Close acForm, "BingoTafel_Beamer", acSaveYes
End Sub

Folgender Vorschlag:

Lösche alle Buttons auf deinem Tabellenblatt (Sheet)

Färbe die Cellen C2 bis C... Grau, formatiere diese Zellen:

Ausrichtung Horizontal und Vertikal Zentriert

Rahmen darum

Schutz = Haken (ja)

Selber Vorgang für E2 bis E...

Inhalt '- oder '+ (Hochkomma und Minus oder Plus)

Nun sollte die Zelle einem Button ähnlich sehen

Jetzt markierts du noch die Werte-Zellen (D2 bis D...)

diese stellst du über Format Zellen auf Schutz nein (kein Haken)

Jetzt den Blattschutz einschalten.

dann schreibst du noch folgenden Code in den Code-Bereich des Blattes (Tablle1?):

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'MsgBox Target.Address
If Target.Column = 3 Then
    Target.Offset(0, 1) = Target.Offset(0, 1) - 1
    ' "Button" verlassen
    ActiveCell.Offset(0, 1).Activate
ElseIf Target.Column = 5 Then
    Target.Offset(0, -1) = Target.Offset(0, -1) + 1
    ' "Button" verlassen
    ActiveCell.Offset(0, -1).Activate
End If
End Sub

Und schon funzt es.

Das ActiveCell.Offset(0, -1).Activate und ActiveCell.Offset(0, 1).Activate dient nur dazu, die Zelle zu verlassen, damit man mehrfach hintereinander den selben "Button" drücken kann.

Hoffe es hilft

Das kommt darauf an, wie gut du auf die dahinterliegende SQL-Datenbank zugreifen kannst. Ist dieses möglich, musst du eine Ergänzungsabfrage unter SQL starten. Das genaue Procedere müssten dir aber Menschen mit besseren SQL-Kenntnissen erklären.

Dann einfach mal neue Frage stellen "Ergänzungsabfrage unter SQL", Themen Datenbank SQL....

Meine rudimentären SQL-Kenntnisse könnten da zu einer Gefahr für einen Datenverlust bei deiner Datenbank führen.

Suboptimierer hat Recht, kein VBA nötig.

Aber seine Lösung ist nur suboptimal, es geht ohne Verketten und ohne zusätzliche Spalte:

in die Eigenschaften der Combobox gehen und

ColumnCount-Eigenschaft auf 4 setzen

RowSource-Eigenschaft auf Tabelle10!A1:D28

Wobei Tabelle10 durch den Namen deiner Tabelle ersetzt werden muss und die 28 mit der letzten Zeile, die du haben möchtest.

Im VBA würde es so aussehen:

Private Sub UserForm_Activate()
Dim MyRange As String
    
ComboBox1.ColumnCount = 4
MyRange = "Tabelle10!A1:D" & Sheets("Tabelle10").UsedRange. _
           SpecialCells(xlLastCell).Row
           
ComboBox1.RowSource = MyRange
End Sub

Hier ist die letzte Zeile sogar dynamisch.

Deine Bilder sind nicht lesbar, daher schau mal in diese Anwort, die zeigt, wie man Code als Code eingibt:

http://www.gutefrage.net/frage/word-2010-pfadvorgabe-beim-speichern#answer131238529

Nun zu deinem Problem, versuch es mal mit folgendem Code:

Sub Tagesnamen()
Dim myDatum As Date
Dim MyWochenTag As String
Dim MyAusgabe As String

myDatum = "21.08.2014"

MyWochenTag = Weekday(myDatum, vbSunday)

Select Case MyWochenTag
Case vbSunday
    MyAusgabe = "Sonntag"
Case vbMonday
    MyAusgabe = "Montag"
Case vbTuesday
    MyAusgabe = "Dienstag"
Case vbWednesday
    MyAusgabe = "Mittwoch"
Case vbThursday
    MyAusgabe = "Donnerstag"
Case vbFriday
    MyAusgabe = "Freitag"
Case vbSaturday
    MyAusgabe = "Samstag"
End Select

MsgBox MyAusgabe
End Sub

Bitte um Rückmeldung, ob es das ist, was du suchst

Versuch es mal so:

Private Sub UserForm_Initialize()
'Code von PauleVBA von  w w w .Gutefrage . net 08/2014

Dim LastRow As Long
Dim I As Long
Dim J As Long
ReDim Liste(1) As String
    J = 1
    LastRow = Worksheets("Daten").Range("B:B").End(xlDown).Row
    For I = 1 To LastRow
        If Cells(I, 7) = "nein" Then
            ReDim Preserve Liste(J)
            Liste(J) = Cells(I, 2).Text
            J = J + 1
        End If
    Next I
     ListBox1.List() = Liste()
End Sub

Da ich das äußere With Me.txtDatum... nicht verstehe, habe ich es weg gelassen. Erbitte Rückmeldung, ob es das ist, was du brauchst

Oder hier die elegantere Lösung:

Sub TeileText_2()
Dim lng_LastRow As Long
Dim I As Long
Dim str_Langtext As String
Dim str_Atext As String
Dim str_Btext As String

lng_LastRow = Range("A:A").SpecialCells _
                 (xlCellTypeLastCell).Row
For I = 1 To lng_LastRow
    str_Langtext = Cells(I, 1)
    If InStr(1, str_Langtext, "=", vbTextCompare) > 0 Then
        str_Atext = Left(str_Langtext, InStr(str_Langtext, "="))
        Cells(I, 1) = str_Atext
        str_Btext = Mid(str_Langtext, InStr(str_Langtext, "=") _
                      + 1, Len(str_Langtext))
        Cells(I, 2) = CDbl(str_Btext)
    End If
Next I
End Sub

Die ist zwar nicht so schnell zu durchschauen, aber eben mit einer Variablen und einer Schleife weniger. Vermutlich ist sie dadurch schneller (bei großen Datenmengen)

Ebenfalls kein "Befehl", sondern ein VBA-Code, funzt bei mir auch.

Versuch es mal damit:

Sub TeileText()
Dim lng_LastRow As Long
Dim I As Long
Dim J As Long
Dim str_Langtext As String
Dim str_Atext As String
Dim str_Btext As String

lng_LastRow = Range("A:A").SpecialCells _
                 (xlCellTypeLastCell).Row
For I = 1 To lng_LastRow
    str_Langtext = Cells(I, 1)
    For J = 1 To Len(str_Langtext)
        If Mid(str_Langtext, J, 1) = "=" Then
            str_Atext = Left(str_Langtext, J)
            Cells(I, 1) = str_Atext
            str_Btext = Mid(str_Langtext, J + 1, _
                              Len(str_Langtext))
            Cells(I, 2) = CDbl(str_Btext)
        End If
    Next J
Next I
End Sub

Ist zwar kein "Befehl", sondern ein VBA-Code, funzt bei mir aber.