habe noch mit Makrorekorder getestet - so OK?
08.01.2017 11:59:32
Wolfgang
Hallo Franz,
ich habe mir eine zweite Mappe mit den zu sortierenden Spalten nachgebaut und konnte die Sortierung somit mit Makrorekorder aufzeichnen. Funktioniert, so meine ich, auch soweit. Wärst Du so nett, noch vielleicht einen Blick darauf zu werfen, ob Dir da noch etwas auffällt bzw. noch verändert werden könnte/müsste?
Ich würde den Code für die Sortierung nach Eintrag von neuen Daten laufen lassen.
Danke Dir schon jetzt recht herzlich!
Gruß - Wolfgang
Code mit Makrorekorder
Sub Datum_sortieren()
Application.ScreenUpdating = False
Cells.Select
ActiveWorkbook.Worksheets("Daten").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Daten").Sort.SortFields.Add Key:=Range("F2:F260"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Daten").Sort.SortFields.Add Key:=Range("H2:H260"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Daten").Sort
.SetRange Range("A1:J260")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
Application.ScreenUpdating = True
End Sub
Bisherige Codes aus dem UF
Option Explicit
Dim rngFind As Range
Dim rngID As Range
Dim Bol As Boolean
Private Sub CommandButton3_Click()
Dim letzte_Zeile As Long
With Worksheets("Daten")
' Datensatz neu speichern
letzte_Zeile = .Range("A65536").End(xlUp).Offset(1, 0).Row
.Cells(letzte_Zeile, 1) = .Cells(letzte_Zeile - 1, 1) + 1
.Cells(letzte_Zeile, 2) = TextBox1.Text
.Cells(letzte_Zeile, 3) = ComboBox1.Text
.Cells(letzte_Zeile, 4) = TextBox2
.Cells(letzte_Zeile, 5) = TextBox3.Text
If Me.TextBox4 = "" Then
.Cells(letzte_Zeile, 6).ClearContents
Else
.Cells(letzte_Zeile, 6) = CDate(TextBox4.Text)
End If
If Me.TextBox5 = "" Then
.Cells(letzte_Zeile, 7).ClearContents
Else
.Cells(letzte_Zeile, 7) = CDate(TextBox5.Text)
End If
.Cells(letzte_Zeile, 8) = TextBox6.Text
.Cells(letzte_Zeile, 9) = Me.ComboBox2.Text
End With
ClearAll
UserForm_Initialize
ComboBox1.SetFocus
Unload Me
End Sub
Private Sub CommandButton5_Click()
If ComboBox1.Text = "" Then
'UserForm schließen
Bol = False
Unload UserForm1
Exit Sub
Else
If MsgBox("Den angezeigten Datensatz speichern ?", 36, "Sicherheitsabfrage") = vbYes Then
CommandButton3_Click
End If
Bol = False
Unload UserForm1
End If
End Sub
Private Sub CommandButton2_Click()
' Datensatz ändern
If Not rngID Is Nothing Then
'rngID.Value = ComboBox1.Text
rngID.Offset(0, 1).Value = TextBox1.Text
rngID.Offset(0, 3).Value = TextBox2.Text
rngID.Offset(0, 4).Value = TextBox3.Text
If Me.TextBox4 = "" Then
rngID.Offset(0, 5).ClearContents
Else
rngID.Offset(0, 5).Value = CDate(TextBox4.Text)
End If
If Me.TextBox5 = "" Then
rngID.Offset(0, 6).ClearContents
Else
rngID.Offset(0, 6).Value = CDate(TextBox5.Text)
End If
rngID.Offset(0, 7).Value = TextBox6.Text
rngID.Offset(0, 8).Value = Me.ComboBox2.Text
Else
rngFind.Value = ComboBox1.Text
rngFind.Offset(0, -1).Value = TextBox1.Text
rngFind.Offset(0, 1).Value = TextBox2.Text
rngFind.Offset(0, 2).Value = TextBox3.Text
If Me.TextBox4 = "" Then
rngFind.Offset(0, 3).ClearContents
Else
rngFind.Offset(0, 3).Value = CDate(TextBox4.Text)
End If
If Me.TextBox5 = "" Then
rngFind.Offset(0, 4).ClearContents
Else
rngFind.Offset(0, 4).Value = CDate(TextBox5.Text)
End If
rngFind.Offset(0, 5).Value = TextBox6.Text
rngFind.Offset(0, 6).Value = Me.ComboBox2.Text
End If
ClearAll
UserForm_Initialize
ComboBox1.SetFocus
Unload Me
End Sub
Private Sub CommandButton4_Click()
Dim a As Integer
Dim msg
Dim letzte_Zeile As Long
'Datensatz löschen
letzte_Zeile = Worksheets("Daten").Range("A65536").End(xlUp).Row
If Not rngID Is Nothing Then
a = rngID + 1
Else
a = Range(rngFind.Address).Row
End If
If MsgBox(" Datensatz wirklich löschen ?", vbYesNo) = vbNo Then
Exit Sub
Else
Range(Cells(a, "B"), Cells(a, "J")).Delete shift:=xlShiftUp
Cells(letzte_Zeile, "A").ClearContents
End If
ClearAll
UserForm_Initialize
ComboBox1.SetFocus
Unload Me
End Sub
Private Sub CommandButton1_Click()
Dim sSearch As String
Dim firstAddress
Dim i As Integer
'Datensatz suchen
If ComboBox1.Text = "" Then
MsgBox "Geben Sie bitte einen Suchbegriff ein !"
Exit Sub
Else
sSearch = ComboBox1.Text
Set rngFind = Columns("C:C").Find(what:=sSearch, lookat:=xlWhole, LookIn:=xlValues)
If rngFind Is Nothing Then
If MsgBox("Dieser Datensatz existiert noch nicht !" & vbCrLf & vbCrLf & " Möchten Sie ihn _
jetzt neu anlegen ?", vbQuestion + vbYesNo, "Nachfragen") = vbNo Then
ComboBox1.Text = ""
ComboBox1.SetFocus
Exit Sub
Else
ComboBox1.SetFocus
End If
Else
i = 0
firstAddress = rngFind.Address
Do
ListBox1.AddItem
ListBox1.List(i, 0) = rngFind.Offset(0, -2).Value
ListBox1.List(i, 1) = rngFind.Offset(0, -1).Value
ListBox1.List(i, 2) = rngFind
ListBox1.List(i, 3) = rngFind.Offset(0, 1).Value
ListBox1.List(i, 4) = rngFind.Offset(0, 2).Value
ListBox1.List(i, 5) = rngFind.Offset(0, 3).Value
ListBox1.List(i, 6) = rngFind.Offset(0, 4).Value
Set rngFind = Columns("C:C").FindNext(rngFind)
i = i + 1
Loop While Not rngFind Is Nothing And rngFind.Address firstAddress
End If
End If
If ListBox1.ListCount = 1 Then
TextBox1.Text = rngFind.Offset(0, -1).Value
TextBox2.Text = rngFind.Offset(0, 1).Value
TextBox3.Text = rngFind.Offset(0, 2).Value
TextBox4.Text = rngFind.Offset(0, 3).Text
TextBox5.Text = rngFind.Offset(0, 4).Text
TextBox6.Text = rngFind.Offset(0, 5).Value
Me.ComboBox2.Text = rngFind.Offset(0, 6).Text
ListBox1.Clear
End If
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim sSearch As String
If ListBox1.ListCount > 1 Then
sSearch = ListBox1.List(ListBox1.ListIndex, 0)
Set rngID = Columns("A:A").Find(what:=sSearch, lookat:=xlWhole, LookIn:=xlValues)
If Not rngID Is Nothing Then
TextBox1.Text = rngID.Offset(0, 1).Value
TextBox2.Text = rngID.Offset(0, 3).Value
TextBox3.Text = rngID.Offset(0, 4).Value
TextBox4.Text = rngID.Offset(0, 5).Text
TextBox5.Text = rngID.Offset(0, 6).Text
TextBox6.Text = rngID.Offset(0, 7).Value
Me.ComboBox2.Text = rngID.Offset(0, 8).Text
End If
sSearch = ""
End If
ListBox1.Clear
End Sub
Private Sub TextBox4_Exit(ByVal Cancel As MSForms.ReturnBoolean)
With Me.TextBox4
If .Text = "" Then
ElseIf IsDate(.Text) Then
.Value = Format(CDate(.Text), "DD.MM.YYYY")
Else
Cancel = True
MsgBox "Eingabe für ""von"" ist kein gültiges Datum"
End If
End With
End Sub
Private Sub TextBox5_Exit(ByVal Cancel As MSForms.ReturnBoolean)
With Me.TextBox5
If .Text = "" Then
ElseIf IsDate(.Text) Then
.Value = Format(CDate(.Text), "DD.MM.YYYY")
Else
Cancel = True
MsgBox "Eingabe für ""bis"" ist kein gültiges Datum"
End If
End With
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'Fehlermeldung, wenn versucht wird, die UserForm über das
'Schließenkreuz oben rechts zu schließen
If CloseMode = 0 Then
' MsgBox "Bitte verlassen Sie die Eingabemaske nur mit der Schaltfläche - Beenden.", _
' vbOKOnly + vbInformation, "Bitte Schaltfläche betätigen."
Cancel = 1
End If
End Sub
Public Sub UserForm_Initialize()
Dim a As Integer
Dim az As Integer ' Zähler für Arrayfelder
Dim i As Integer ' Schleifenzähler (Arrays füllen)
Dim arr() As Variant ' Array für Datenausgabe
a = Sheets("Daten").Range("A65536").End(xlUp).Row
' Array dimensionieren
ReDim arr(a, 0) ' Feld nach Listenlänge festlegen
' Arrays mit Werten füllen
For i = 2 To UBound(arr) ' laufe von Zeile 2 bis _
Tabellenende
If Application.WorksheetFunction.CountIf(Range(Cells(i, 1), _
Cells(1, 3)), Cells(i, 3).Value) = 1 Then ' wenn Wert das erste _
Mal vorkommt, dann ...
arr(az, 0) = Cells(i, 3).Value ' ... Name in Array _
einlesen
az = az + 1 ' ... Zähler für _
Arrayfeld plus 1
End If ' Ende der Auswertung
Next i
ComboBox1.List = arr
With Me.ComboBox2
.AddItem ""
.AddItem "zugewiesen"
.AddItem "Teilnahme"
.AddItem "zurückgezogen"
End With
With ListBox2
.ColumnCount = 2
.ColumnWidths = "75pt; 50pt"
.List = Sheets("Termine").Range("A1:B14").Value
End With
'ListBox2.List = Sheets("Termine").Range("A1:B14").Value
End Sub
Private Sub UserForm_Activate()
'Datum und Uhrzeit anzeigen
Label9.Caption = Date
Bol = True
Do Until Bol = False
DoEvents
Label10.Caption = Time
Loop
End Sub
Sub ClearAll()
Dim C As Integer
On Error Resume Next
ComboBox1.Text = ""
For C = 1 To 6
Me.Controls("TextBox" & CStr(C)).Text = ""
Next C
Me.ComboBox2 = ""
End Sub