AW: Sheet kopieren, füllen und aktuallisieren
23.04.2010 16:12:29
fcs
Hallo Christian,
wenn du schon eine Beispieldatei hochlädst, dann sollte doch wenigstens das was drin ist rund laufen. Hier passen die Tabellennamen in den Prozeduren noch nicht mit denen in der Tabelle.
Ansonsten muss du das Blatt für einen neuen Namen einfügen, bevor du die Namens-tabelle neu sortierts. Dann stehen die Daten noch in der letzten Zeile. Alternativ kannst du ja auch die Infos aus dem Userfom verwenden, denn da stehen die Daten ja auch noch drin.
Gruß
Franz
Die folgenden Prozeduren des UF muss du Ergänzen bzw. Anpassen.
Private Sub BlattAnlegen(ByVal lZeile As Long)
Dim wksNeu As Worksheet, wksNamen As Worksheet
Dim sBlattName As String, iNr As Long
Set wksNamen = Worksheets("Namensliste")
With ActiveWorkbook
.Worksheets("Stammblatt").Copy After:=.Sheets(.Sheets.Count)
End With
Set wksNeu = ActiveSheet
With wksNamen
sBlattName = .Cells(lZeile, 1) & ", " & .Cells(lZeile, 2)
BlattNamePruefen:
If fncCheckBlattname(sText:=sBlattName) = True Then
'Blattname existiert schon, Nr wird angefügt
iNr = iNr + 1
sBlattName = sBlattName & "(" & iNr & ")"
GoTo BlattNamePruefen
Else
wksNeu.Name = sBlattName
End If
Call WerteEintragen(lZeile:=lZeile, wks:=wksNeu)
'namensliste wieder anzeigen
.Activate
End With
End Sub
Private Sub WerteEintragen(ByVal lZeile As Long, wks As Worksheet)
'Werte aus Zeile lZeile in Namensliste in Namensblatt eintragen
Dim wksNamen As Worksheet
Set wksNamen = Worksheets("Namensliste")
With wksNamen
wks.Range("B2") = .Cells(lZeile, 1) 'Name
wks.Range("E2") = .Cells(lZeile, 2) 'Vorname
wks.Range("B4") = .Cells(lZeile, 3) 'Strasse
wks.Range("E2") = .Cells(lZeile, 4) & " " & .Cells(lZeile, 5) 'PLZ Ort
wks.Range("B6") = .Cells(lZeile, 6) 'Telefon
End With
End Sub
Private Function fncCheckBlattname(sText As String) As Boolean
'Prüfen ob Blattname schon vorhanden
Dim oSheet
For Each oSheet In ActiveWorkbook.Sheets
If LCase(oSheet.Name) = LCase(sText) Then
fncCheckBlattname = True
Exit For
End If
Next
End Function
' übernehmen
Private Sub CommandButton1_Click()
Dim lLetzte As Long
Dim iIndex As Integer
If TextBox1.Value = "" Then
MsgBox "Sie müssen einen Familiennamen eingeben - danke.", _
48, " Hinweis für " & Application.UserName
TextBox1.SetFocus
Exit Sub
End If
If TextBox2.Value = "" Then
MsgBox "Sie müssen einen Vornamen eingeben - danke.", _
48, " Hinweis für " & Application.UserName
TextBox2.SetFocus
Exit Sub
End If
If TextBox3.Value = "" Then
MsgBox "Sie müssen einen Straßennamen eingeben - danke.", _
48, " Hinweis für " & Application.UserName
TextBox3.SetFocus
Exit Sub
End If
If TextBox4.Value = "" Then
MsgBox "Sie müssen eine Postleitzahl eingeben - danke.", _
48, " Hinweis für " & Application.UserName
TextBox4.SetFocus
Exit Sub
ElseIf Len(TextBox4.Value) 5 Then
MsgBox "Sie müssen eine 5-stellige Postleitzahl eingeben - danke.", _
48, " Hinweis für " & Application.UserName
TextBox4.SetFocus
Exit Sub
End If
If TextBox5.Value = "" Then
MsgBox "Sie müssen einen Ortsnamen eingeben - danke.", _
48, " Hinweis für " & Application.UserName
TextBox5.SetFocus
Exit Sub
End If
If TextBox7.Value = "" Then
MsgBox "Sie müssen eine Telefonnummer eingeben - danke.", _
48, " Hinweis für " & Application.UserName
TextBox7.SetFocus
Exit Sub
End If
' die Daten sind geprüft und können in die Tabelle eingetragen werden
Application.ScreenUpdating = False
With Worksheets("Namensliste")
.Unprotect Password:="Geheim"
lLetzte = IIf(.Range("A65536") "", 65536, .Range("A65536").End(xlUp).Row) + 1
If lLetzte "" Then
If IsDate(TextBox6.Value) Then
.Range("F" & lLetzte).Value = Format(TextBox6.Value, "dd.mm.yyyy ddd")
ElseIf IsDate(Left(TextBox6.Value, Len(TextBox6.Value) - 3)) Then
.Range("F" & lLetzte).Value = Format(TextBox6.Value, "dd.mm.yyyy ddd")
End If
End If
.Range("G" & lLetzte).Value = TextBox7.Value
'Neues Tabellenblatt mit name anlegen
Call BlattAnlegen(lZeile:=lLetzte)
' Tabelle nach "Nachname", "Vorname", "Postlz" sortieren
.Range(.Cells(1, 1), .Cells(lLetzte, 7)).Sort _
Key1:=.Cells(1, 1), Order1:=xlAscending, _
Key2:=.Cells(1, 2), Order2:=xlAscending, _
Key3:=.Cells(1, 4), Order3:=xlAscending, _
Header:=xlGuess
.Columns("A:G").EntireColumn.AutoFit
Call Zeilen_faerben
With ListBox1
Call Array_fuellen
.Clear
.Column = aTmp
End With
Label8.Caption = "Anzahl Telefon-Einträge: " & (lLetzte - 1)
.Protect Password:="Geheim"
End With
For iIndex = 1 To 7
With Controls("TextBox" & iIndex)
.Value = ""
End With
Next iIndex
Application.ScreenUpdating = True
End Sub