Readdy Write  
0,00 €
Your View Money
Views: Count
Self 20% 0
Your Content 60% 0

Users by Links 0
u1*(Content+Views) 10% 0
Follow-Follower 0
s2*(Income) 5% 0

Count
Followers 0
Login Register as User

Formulare in eine Excel-Datenbank einlesen und verwalten

07.03.2019 (👁16823)

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