|
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
|