AW: Datenbank
14.05.2013 01:29:18
fcs
Hallo Chris,
hier ein Makro, wie man es machen könnte.
Gruß
Franz
Sub Schaltflaeche_Speichern()
Dim wks_Ein As Worksheet, wks_DB As Worksheet
Dim Zeile_DB As Long, Spalte_DB As Long, Zeile_Ein As Long
Dim strDiagnose As String, bolSpeichern As Boolean
Const strTitle As String = "Datenerfassung"
Set wks_Ein = Worksheets("Tabelle1") 'Eingabeblatt
'Eingaben prüfen
bolSpeichern = True
With wks_Ein
If .Cells(1, 2) = "" Then
MsgBox "Name ist nicht eingetragen!", vbOKOnly, strTitle
bolSpeichern = False
End If
If .Cells(11, 2) = "" Then
MsgBox "Medico ist nicht eingetragen!", vbOKOnly, strTitle
bolSpeichern = False
End If
End With
If bolSpeichern = True Then
Set wks_DB = Worksheets("Tabelle2") 'Zieltabelle mit Datenbank
If MsgBox(Prompt:="Datensatz speichern?", Buttons:=vbQuestion + vbYesNo, _
Title:=strTitle) = vbYes Then
With wks_DB
Zeile_DB = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
Zeile_Ein = 0
For Spalte_DB = 1 To 11
Zeile_Ein = Zeile_Ein + 1
Select Case Zeile_Ein
Case 7 'BMI
'Zahlenwert runden
.Cells(Zeile_DB, Spalte_DB).Value = _
Application.WorksheetFunction.Round(wks_Ein.Cells(Zeile_Ein, 2).Value, 1)
Case Else
.Cells(Zeile_DB, Spalte_DB).Value = wks_Ein.Cells(Zeile_Ein, 2).Value
End Select
Next
'Aufnahmendiagnose zu einem Text zusammenfassen
With wks_Ein
strDiagnose = ""
For Zeile_Ein = 14 To 19
If .Cells(Zeile_Ein, 2) "" Then
If strDiagnose = "" Then
strDiagnose = .Cells(Zeile_Ein, 2)
Else
strDiagnose = strDiagnose & Chr(10) & .Cells(Zeile_Ein, 2).Text
End If
End If
Next
End With
If strDiagnose "" Then
Spalte_DB = 12
.Cells(Zeile_DB, Spalte_DB).Value = strDiagnose
End If
End With
'Altdaten im Eingabeblatt lschen
With wks_Ein
.Range("B1:B6").ClearContents
.Range("B9:B19").ClearContents
End With
End If
End If
End Sub