für jede gefüllte Zelle...

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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

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)?

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

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

für jede gefüllte Zelle...

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

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread