Excel Datenbank mit Eingabeformularen
Die folgende Excel Anwendung zeigt eine Excel Datei, welche Formular einliest und in sich selbst als Datenbank speichert.
Eingabeformular Beispiel
Die Eingabeformulare sollten alle in einem Eingabeordner sein. Eine andere Auswahl ist natürlich möglich beim Import Dialog
Zum Einlesen muss man nur einen Import Button drücken
Dann kann man die Dateien auswählen, welche man einlesen möchte
Nach dem Einlesen wird der Import mit Fertig bestätigt
Datenbank
Die Daten werden automatisch in das Blatt Daten in eine Liste / ListObject geschrieben.
Neue Daten werden anhand der ID neu eingetragen, alte Formulare überscheiben die Zeile mit der passenden ID
Auswertung
Unter Auswertung werden die Daten der Tabelle automatisch in einer Pivot ausgewertet
Formulare durchblättern
Unter dem Excel Blatt Eingabe (wie das Eigentliche Formular) kann man die Datentabelle durchblättern.
Dabei werden alle Felder anhand der Tabelle und anhand der Namensvariablen gefunden.
Code: Import Formular in die ListObject Datentabelle
Option Explicit
'Const const_ImportPath As String = ""
Public Sub Import() '-------------< Import() >------------ '*Reference Microsoft Scripting Runtime http://www.microsoft-programmierer.de/Details?d=1076
'------< Insert Pictures From Folder >------ '--< Import-Dialog >-- Dim objFiledialog As FileDialog Set objFiledialog = Application.FileDialog(msoFileDialogFilePicker) objFiledialog.AllowMultiSelect = True objFiledialog.ButtonName = "Formulare importieren" objFiledialog.Filters.Add "Excel Formulare", "*.xlsx;*.xlsm" objFiledialog.Title = "Formulare auswählen" objFiledialog.InitialView = msoFileDialogViewTiles objFiledialog.InitialFileName = ThisWorkbook.Path & "\03_Eingabe\" objFiledialog.AllowMultiSelect = True If Not objFiledialog.Show() = True Then Exit Sub End If '--< Import-Dialog >--
'-< check >- '</ Ordner ist leer > If objFiledialog.SelectedItems().Count = 0 Then Exit Sub End If '</ Ordner ist leer > '-</ check >-
Dim iFile As Integer For iFile = 1 To objFiledialog.SelectedItems.Count '------< Loop.Item >------ DoEvents
'< get selection > Dim sFilename As String sFilename = objFiledialog.SelectedItems(iFile) Application.StatusBar = Now & " " & sFilename '</ get selection >
'< get Extension > Dim sExtension As String Dim intLen_Extension As Integer intLen_Extension = InStrRev(sFilename, ".", -1, vbBinaryCompare) sExtension = Mid(LCase(sFilename), intLen_Extension) '</ get Extension >
If InStr(1, "*.xlsx,*.xlsm", sExtension) > 0 Then 'JPG-Datei Import_Datei sFilename End If Next
'-------------</ Import() >------------ End Sub
Public Sub Import_Datei(ByVal sFilename As String) '-------------< Import_Datei() >------------
Dim wb As Workbook Set wb = ThisWorkbook
'< oeffnen > On Error Resume Next Dim app As New Application Set app = New Application app.Visible = False Dim wbImport As Workbook Set wbImport = app.Workbooks.Open(sFilename, UpdateLinks:=False, ReadOnly:=True)
If Err.Number <> 0 Then MsgBox "Fehler beim öffnen Datei: " & vbCrLf & sFilename & vbCrLf & Err.Description Exit Sub End If '</ oeffnen >
Dim wsImport As Worksheet Set wsImport = wbImport.Sheets("Eingabe")
'----< ID_ermitteln >---- Dim sAddress_ID As String sAddress_ID = wb.Names("Feld_ID").RefersToRange.Address
Dim sID As String sID = wsImport.Range(sAddress_ID).Value sID = Trim(sID)
'< check > If sID = "" Then MsgBox "keine ID gefunden in " & wb.Name, vbCritical, "Abbruch" Exit Sub End If '</ check >
Dim list_Daten As ListObject Set list_Daten = wb.Sheets("Daten").ListObjects("tblDaten")
Dim lRow As Listrow
Dim row_Find As Range Set row_Find = list_Daten.ListColumns("ID").DataBodyRange.Find(sID) If row_Find Is Nothing Then Set lRow = list_Daten.ListRows.Add Else Set lRow = list_Daten.ListRows(row_Find.row - list_Daten.Range.row) End If '----</ ID_ermitteln >----
'------< Import_Input_Values >------ '----< @Loop: Namesvariablen >---- Dim varName As Name Dim iFeld As Integer iFeld = 0 For Each varName In wb.Names If varName.Name Like "Feld_*" Then '---< Ist_Namesvariable_mit_Kennung >--- '-< init >- iFeld = iFeld + 1
Dim sAddress As String sAddress = varName.RefersToRange.Address Dim sFeldName As String sFeldName = varName.Name
Dim sName As String sName = Replace(sFeldName, "Feld_", "", 1, 1, vbTextCompare)
Dim sWert As String 'Variant sWert = wsImport.Range(sAddress).Value '-</ init >-
list_Daten.ListColumns(sName).DataBodyRange(lRow.Index).Value = sWert
Application.StatusBar = Now & " " & iFeld & " " & sAddress & "=" & sWert
'wb.Worksheets("Daten").Cells(1, iFeld).Value = sName '---</ Ist_Namesvariable_mit_Kennung >--- End If Next '----</ @Loop: Namesvariablen >----
'----< @Loop: optional_Control_Inputs >---- '*Excel Checkboxen Dim ctl As Shape For Each ctl In wbImport.Worksheets("Eingabe").Shapes If ctl.Type = msoFormControl Then '---< Ist_Namesvariable_mit_Kennung >--- Dim ctlCheckbox As Shape Set ctlCheckbox = ctl
Dim sCheckbox_Text As String sCheckbox_Text = ctl.AlternativeText '< correktur > '*loesche Klammer-Texte wie Vorjahr(VJ) Dim posCheck As Integer posCheck = InStr(1, sCheckbox_Text, "(", vbBinaryCompare) If InStr(1, sCheckbox_Text, "(", vbBinaryCompare) > 0 Then sCheckbox_Text = Mid$(sCheckbox_Text, 1, posCheck - 1) sCheckbox_Text = Trim(sCheckbox_Text) End If '</ correktur >
'-< init >- Dim optChecked As Boolean If ctlCheckbox.Child = msoFalse Then 'Excel Checkbox.child=checked optChecked = True Else optChecked = False End If '-</ init >-
list_Daten.ListColumns(sCheckbox_Text).DataBodyRange(lRow.Index) = optChecked
Application.StatusBar = Now & " " & sCheckbox_Text & "=" & optChecked
'---</ Ist_Namesvariable_mit_Kennung >--- End If Next '----</ @Loop: optional_Control_Inputs >----
'------</ Import_Input_Values >------
'--< Datei_Notizen >-- list_Daten.ListColumns("Datei").DataBodyRange(lRow.Index) = wbImport.Name list_Daten.ListColumns("Pfad").DataBodyRange(lRow.Index) = wbImport.Path list_Daten.ListColumns("Bearbeiter").DataBodyRange(lRow.Index) = wbImport.BuiltinDocumentProperties("Last author").Value list_Daten.ListColumns("Datum_Bearbeitung").DataBodyRange(lRow.Index) = wbImport.BuiltinDocumentProperties("Last save time").Value list_Daten.ListColumns("Datum_Import").DataBodyRange(lRow.Index) = Now '--</ Datei_Notizen >--
'< Abschluss > wbImport.Close SaveChanges:=False Set wbImport = Nothing app.Quit '</ Abschluss > '-------------</ Import_Datei() >------------ End Sub |
Liste anzeigen
Code in vba
Option Explicit
Private Sub ctlListe_Change() '-------------< ctlListe_Change() >-------------
Dim sID As String sID = ctlListe.Value
If sID Like "" Then Reset_Formular Exit Sub End If
If Not Application.ActiveSheet.Name = "Eingabe" Then Exit Sub '< speed > 'Application.Calculation = xlManual 'Application.ScreenUpdating = False '*speed row ausblenden true->false 'Application.EnableEvents = False 'ActiveSheet.DisplayPageBreaks = False '< speed >
'----< ID_ermitteln >---- Dim list_Daten As ListObject Set list_Daten = Sheets("Daten").ListObjects("tblDaten")
Dim lRow As Listrow
Dim row_Find As Range Set row_Find = list_Daten.ListColumns("ID").DataBodyRange.Find(sID) If row_Find Is Nothing Then Set lRow = list_Daten.ListRows.Add Else Set lRow = list_Daten.ListRows(row_Find.row - list_Daten.Range.row) End If '----</ ID_ermitteln >----
'------< Import_Input_Values >------ '----< @Loop: Namesvariablen >---- Dim varName As Name Dim iFeld As Integer iFeld = 0 For Each varName In ThisWorkbook.Names If varName.Name Like "Feld_*" And Not varName.Name Like "Feld_Opt*" Then '---< Ist_Namesvariable_mit_Kennung >--- '-< init >- iFeld = iFeld + 1
Dim sName As String sName = Replace(varName.Name, "Feld_", "", 1, 1, vbTextCompare) '-</ init >-
Dim sWert As Variant sWert = list_Daten.ListColumns(sName).DataBodyRange(lRow.Index)
varName.RefersToRange.Value = sWert
'Application.StatusBar = Now & " " & iFeld & " " & sName & "=" & sWert
'---</ Ist_Namesvariable_mit_Kennung >--- End If Next '----</ @Loop: Namesvariablen >----
'----< @Loop: optional_Control_Inputs >---- ' '*Excel Checkboxen ' Dim ctl As Shape ' For Each ctl In ThisWorkbook.Worksheets("Eingabe").Shapes ' If ctl.Type = msoFormControl Then ' '---< Ist_Namesvariable_mit_Kennung >--- ' ' Dim ctlCheckbox As Shape ' Set ctlCheckbox = ctl ' ' Dim sCheckbox_Text As String ' sCheckbox_Text = ctl.AlternativeText ' '< correktur > ' '*loesche Klammer-Texte wie Vorjahr(VJ) ' Dim posCheck As Integer ' posCheck = InStr(1, sCheckbox_Text, "(", vbBinaryCompare) ' If InStr(1, sCheckbox_Text, "(", vbBinaryCompare) > 0 Then ' sCheckbox_Text = Mid$(sCheckbox_Text, 1, posCheck - 1) ' sCheckbox_Text = Trim(sCheckbox_Text) ' End If ' '</ correktur > ' ' Dim optChecked As Boolean ' optChecked = list_Daten.ListColumns(sCheckbox_Text).DataBodyRange(lRow.Index) ' ' '-< init >- ' If optChecked = False Then 'Excel Checkbox.child=checked ' ctlCheckbox.ControlFormat.Value = xlOff ' Else ' ctlCheckbox.ControlFormat.Value = xlOn ' End If ' '-</ init >- ' 'Application.StatusBar = Now & " " & sCheckbox_Text & "=" & optChecked ' ' '---</ Ist_Namesvariable_mit_Kennung >--- ' End If ' Next '----</ @Loop: optional_Control_Inputs >----
'--< Datei_Notizen >-- ThisWorkbook.Names("Datei").RefersToRange.Value = list_Daten.ListColumns("Datei").DataBodyRange(lRow.Index) ThisWorkbook.Names("Bearbeiter").RefersToRange.Value = list_Daten.ListColumns("Bearbeiter").DataBodyRange(lRow.Index) ThisWorkbook.Names("Datum_Bearbeitung").RefersToRange.Value = list_Daten.ListColumns("Datum_Bearbeitung").DataBodyRange(lRow.Index) ThisWorkbook.Names("Datum_Import").RefersToRange.Value = list_Daten.ListColumns("Datum_Import").DataBodyRange(lRow.Index) '--</ Datei_Notizen >--
'< speed > 'ActiveSheet.DisplayPageBreaks = True 'Application.Calculation = xlAutomatic 'Application.ScreenUpdating = True 'Application.EnableEvents = True '< speed >
'-------------</ ctlListe_Change() >------------- End Sub
Private Sub Reset_Formular() '-------------< Reset_Formular() >-------------
'------< Import_Input_Values >------ '----< @Loop: Namesvariablen >---- Dim varName As Name Dim iFeld As Integer iFeld = 0 For Each varName In ThisWorkbook.Names If varName.Name Like "Feld_*" And Not varName.Name Like "Feld_Opt*" Then '---< Ist_Namesvariable_mit_Kennung >--- '-< init >- varName.RefersToRange.Value = "" '---</ Ist_Namesvariable_mit_Kennung >--- End If Next '----</ @Loop: Namesvariablen >----
'----< @Loop: optional_Control_Inputs >---- '*Excel Checkboxen Dim ctl As Shape For Each ctl In ThisWorkbook.Worksheets("Eingabe").Shapes If ctl.Type = msoFormControl Then '---< Ist_Namesvariable_mit_Kennung >---
'ctl.ControlFormat.Value = xlOff '-</ init >-
'---</ Ist_Namesvariable_mit_Kennung >--- End If Next '----</ @Loop: optional_Control_Inputs >----
'-------------</ Reset_Formular() >------------- End Sub |