Live-Forum - Die aktuellen Beiträge
Datum
Titel
15.10.2025 11:29:24
Algorhitmus, der kleinste Summe von Zahlen berechnet
15.10.2025 10:27:00
Zusammenführen / Synchronisieren von zwei Dateien
15.10.2025 09:51:49
Wenns mit Zahl und Buchstaben
15.10.2025 08:22:15
Privat Sub ObjExcel_Sheet Change....deaktivieren
Keine passende Antwort im Forumarchiv gefunden?
Stelle deine Frage im Live-Forum
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1516to1520
1516to1520
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

für jede gefüllte Zelle...

Forumthread: für jede gefüllte Zelle...

für jede gefüllte Zelle...
07.10.2016 09:14:49
Berndt
Hallo,
ich brauche eine kleine Hilfe bzgl. folgenden des folgenden Problems:
- betrachte nur die Sheets welche mit Herr* oder Frau* beginnen
For Each Worksheet In ActiveWorkbook.Worksheets
If LCase(Left(wksQuelle.Name, 5)) = "herr " Or LCase(Left(wksQuelle.Name, 5)) = "frau " Then
End If
Next
- suche mir in den Sheets in Spalte B "aus Themenspeicher übertragen* (das ist mein Tabellenkopf)
- darunter stehen Einträge (unterschiedlich viele)
für jede befüllte Zelle in Spalte B unter den Spaltenkopf soll es mir in Spalte A (eine Zelle links von B^^)ein Zelle formatieren (gepunktete Linie unten und eine Datenüberprüfung (Dropdownauswahlmöglichkeit= "x") einfügen).
Ist das umsetzbar?
VG Berndt
Anzeige

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: für jede gefüllte Zelle...
07.10.2016 09:47:54
UweD
Hallo
Ist das umsetzbar?
Ich denke schon...
Sub Makro2()
    Dim WS As Worksheet, Z As Range, wksQuelle
    
    For Each WS In ActiveWorkbook.Worksheets
        If LCase(Left(WS.Name, 5)) = "herr " Or LCase(Left(WS.Name, 5)) = "frau " Then
            For Each Z In WS.Columns(2).SpecialCells(xlCellTypeFormulas, 3) ' Bei Formeln 
                If Z.Row > 1 Then 'erst ab Zeile 2 
                    With Z.Offset(0, -1).Borders(xlEdgeBottom) ' Linie setzen 
                        .LineStyle = xlDot
                        .TintAndShade = 0
                        .Weight = xlThin
                    End With
                    With Z.Offset(0, -1).Validation 'Datenüberprüfung auf X 
                        .Delete
                        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
                            Operator:=xlBetween, Formula1:="X"
                        .IgnoreBlank = True
                        .InCellDropdown = True
                        .ShowInput = True
                        .ShowError = True
                    End With
                
                End If
            Next
        End If
    Next
End Sub

'oder wenn Konstante Werte in Spalte B stehen 
'For Each Z In WS.Columns(2).SpecialCells(xlCellTypeConstants, 3) 



VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 15 - mit VBAHTML 12.6.0
LG UweD
Anzeige
AW: für jede gefüllte Zelle...
07.10.2016 10:06:12
Berndt
vielen Dank für deine schnelle Antwort.
Ich zeig dir mal eine Bsp. Datei, da dein Makro nicht so recht funktioniert.
https://www.herber.de/bbs/user/108638.xlsm
zu sehen sind im sheet Herr A die eingetragenen Zellen unter den Spaltenkopf "aus Themenspeicher übertragen".
Diese Werte werden aus Sheet "Themenspeicher" - Button "Themen an Mitarbeiter übertragen" eingefügt.
Das Makro hinter den Butto sollte nun so erweitert werden, damit es mir in Spalte A eine formatierte Zelle + Datenüberprüfung einfügt.
Anzeige
AW: für jede gefüllte Zelle...
07.10.2016 09:58:18
baschti007
Hey Ho
Ich denke So =D ist zwar nicht schön aber geht .
Gruß Basti

Sub Blaa()
Dim Ws As Worksheet
Dim FindStr As String
Dim maxZell As Long
Dim c As Range
Dim rng As Range
Dim Zell As Range
FindStr = "aus Themenspeicher übertragen"
For Each Ws In ThisWorkbook.Worksheets
If (UCase(Ws.Name) Like "HERR" Or UCase(Ws.Name) Like "FRAU") Then
With Ws.Range("B:B")
Set c = .Find(FindStr, LookIn:=xlValues)
If Not c Is Nothing Then
maxZell = c.Offset(1, 0).End(xlDown)
Set rng = Ws.Range(c.Offset(1, 0), c.Offset(maxZell, 0))
For Each Zell In rng
With Zell.Offset(0, -1).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween,  _
Formula1:="X"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = False
End With
Zell.Offset(0, -1).Value = "....."
Next
End If
End With
End If
Next
End Sub

Anzeige
AW: für jede gefüllte Zelle...
07.10.2016 10:12:09
baschti007
Ups ein kleiner Fehler

If (UCase(WS.Name) Like "*HERR*" Or UCase(WS.Name) Like "*FRAU*") Then
Gruß Basti
AW: für jede gefüllte Zelle...
07.10.2016 10:27:12
Berndt
Habe deinen Teil mal eingefügt in das bisher bestehende Makro. 
Private Sub CommandButton3_Click()
' Themen auf Mitarbeiter verteilen
Dim a
Dim i         As Long
Dim bis       As Long
Dim von       As Long
Dim Treffer   As Range
Dim Ws As Worksheet
Dim FindStr As String
Dim maxZell As Long
Dim c As Range
Dim rng As Range
Dim Zell As Range
Application.ScreenUpdating = False
Set Treffer = Worksheets("Themenspeicher").Columns(2).Find("*Themenspeicher*", LookIn:= _
xlValues)
von = Treffer.Row + 1  'erste Zelle nach Themenspeicher in Sheet Themenspeicher
bis = Worksheets("Themenspeicher").Range("B" & Rows.Count).End(xlUp).Row + 1
a = Range("B" & von & ":E" & bis)
For i = 1 To UBound(a)
If a(i, 2) = "x" Then
bis = Sheets(a(i, 3)).Range("B2000").End(xlUp).Row + 1
If IsError(Application.Match(a(i, 1), Worksheets(a(i, 3)).Range("B1:B" & bis), 0)) _
Then
Sheets(a(i, 3)).Range("B" & bis) = a(i, 1)
Sheets(a(i, 3)).Range("C" & bis) = a(i, 4)
Sheets(a(i, 3)).Range("B8:C8").Copy  ' da ist das gleiche Format
Sheets(a(i, 3)).Range("B" & bis).Resize(, 2).PasteSpecial xlFormats
End If
End If
Next
FindStr = "aus Themenspeicher übertragen"
For Each Ws In ThisWorkbook.Worksheets
If (UCase(Ws.Name) Like "*HERR*" Or UCase(Ws.Name) Like "*FRAU*") Then
With Ws.Range("B:B")
Set c = .Find(FindStr, LookIn:=xlValues)
If Not c Is Nothing Then
maxZell = c.Offset(1, 0).End(xlDown)
Set rng = Ws.Range(c.Offset(1, 0), c.Offset(maxZell, 0))
For Each Zell In rng
With Zell.Offset(0, -1).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop,  _
Operator:=xlBetween, Formula1:="x"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = False
End With
Zell.Offset(0, -1).Value = "....."
Next
End If
End With
End If
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
bei maxZell = c.Offset(1, 0).End(xlDown) bricht mir das Makro ab ("Typen unverträglich)?
Anzeige
AW: für jede gefüllte Zelle...
07.10.2016 10:33:18
baschti007
Ja Gut nur als Tipp besser immer gleich eine Bsp Datei ;)
Guck mal so
Gruß Basti

Sub Blaa()
Dim WS As Worksheet
Dim FindStr As String
Dim maxZell As Long
Dim c As Range
Dim rng As Range
Dim Zell As Range
FindStr = "aus Themenspeicher übertragen"
For Each WS In ThisWorkbook.Worksheets
Debug.Print UCase(WS.Name)
If (UCase(WS.Name) Like "*HERR*" Or UCase(WS.Name) Like "*FRAU*") Then
With WS
With .Range("B:B")
Set c = .Find(FindStr, LookIn:=xlValues)
If Not c Is Nothing Then
maxZell = .Cells(.Rows.Count, 2).End(xlUp).Row - c.Offset(1, 0).Row + 1
If maxZell  0 Then
Set rng = .Range(c.Offset(1, -1), c.Offset(maxZell, -1))
For Each Zell In rng
With Zell.Offset(0, -1).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween,  _
Formula1:="X"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = False
End With
With Zell.Offset(0, -1).Borders(xlEdgeBottom) ' Linie setzen
.LineStyle = xlDot
.TintAndShade = 0
.Weight = xlThin
End With
Next
End If
End If
End With
End With
End If
Next
End Sub

Anzeige
AW: für jede gefüllte Zelle...
07.10.2016 10:33:51
Berndt
also es muss wahrscheinlich an
Dim maxZell As Long
liegen.
AW: für jede gefüllte Zelle...
07.10.2016 10:39:42
Berndt
funktioniert Klasse.
Danke dafür.
;

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Entdecke mehr
Finde genau, was du suchst

Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden

Suche nach den besten Antworten
Unsere beliebtesten Threads

Entdecke unsere meistgeklickten Beiträge in der Google Suche

Top 100 Threads jetzt ansehen
Anzeige