Zahlenformat in makro einbinden
13.10.2016 14:45:00
Berndt
mit folgenden Code transportiere ich Daten aus einen Sheet in mehrere Sheets.
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
Debug.Print UCase(WS.Name)
If (UCase(WS.Name) Like "*HERR*" Or UCase(WS.Name) Like "*FRAU*") Then
WS.Unprotect
With WS
' WS.Unprotect , UserInterfaceOnly:=False
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
' Datenüberprüfung setzen
Zell.Offset(0, -1).Validation.Delete
Zell.Offset(0, -1).Validation.Add Type:=xlValidateList, _
AlertStyle:=xlValidAlertStop, Operator:=xlBetween, _
Formula1:="x"
Zell.Offset(0, -1).Validation.IgnoreBlank = True
Zell.Offset(0, -1).Validation.InCellDropdown = True
Zell.Offset(0, -1).Validation.InputTitle = ""
Zell.Offset(0, -1).Validation.ErrorTitle = ""
Zell.Offset(0, -1).Validation.InputMessage = ""
Zell.Offset(0, -1).Validation.ErrorMessage = ""
Zell.Offset(0, -1).Validation.ShowInput = True
Zell.Offset(0, -1).Validation.ShowError = False
' Linie setzen
Zell.Offset(0, -1).Borders(xlEdgeBottom).LineStyle = xlDot
Zell.Offset(0, -1).Borders(xlEdgeBottom).TintAndShade = 0
Zell.Offset(0, -1).Borders(xlEdgeBottom).Weight = xlThin
' Text mittig setzen
Zell.Offset(0, -1).HorizontalAlignment = xlCenter
Next
End If
End If
End With
End With
WS.Protect , UserInterfaceOnly:=True
End If
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
im Fett und kusiv markierten Teil des Makros kopiert es mir Termine in die versch. Sheets. z.B. "bis 16.09.2016" wird super übertragen, aber z.B. "15.09.2016" zeigt es mir als Zahl an da das Zellenformat Standard eingestellt ist.
Was muss ich im Code zusätzlich noch eingebaut werden, um das Zahlenformat auf "Datum" zu ändern?
Ich hoffe es kann jmd. behilflich sein.
VG
Berndt