AW: Bei Import Teile des Dateinamens auslesen und in Zellen schreiben
24.01.2020 10:52:11
Torsten
Hallo,
dann versuchs mal so:
Public Sub Import()
Dim objWorkbook As Workbook
Dim objTargetSheet As Worksheet
Dim lngEmptyRow As Long, lngLast As Long
Dim str_dateiname As String
Dim fld As FileDialog
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
Set objTargetSheet = ThisWorkbook.Worksheets("Tabelle1")
With objTargetSheet
lngEmptyRow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
End With
Set fld = Application.FileDialog(msoFileDialogFilePicker)
If fld.Show -1 Then
Exit Sub
Else
str_dateiname = fld.SelectedItems(1)
End If
Set objWorkbook = Workbooks.Open(str_dateiname, ReadOnly:=True)
With ThisWorkbook.Sheets("Tabelle1") 'Tabelle anpassen
lngLast = .Cells(Rows.Count, 1).End(xlUp).Row
.Cells(lngLast + 1, 1) = Left(objWorkbook.Name, 5)
.Cells(lngLast + 1, 2) = Mid(objWorkbook.Name, 7, 5)
.Cells(lngLast + 1, 3) = Mid(objWorkbook.Name, 13, 1)
End With
With objWorkbook.Worksheets("Report")
Call .Range("F5").Copy(Destination:=objTargetSheet.Cells(lngEmptyRow, 1))
Call .Range("B5").Copy(Destination:=objTargetSheet.Cells(lngEmptyRow, 2))
Call .Range("D5").Copy(Destination:=objTargetSheet.Cells(lngEmptyRow, 3))
Call .Range("F8").Copy(Destination:=objTargetSheet.Cells(lngEmptyRow, 4))
Call .Range("B14:B104").Copy
Call objTargetSheet.Cells(lngEmptyRow, 5).PasteSpecial( _
Paste:=xlPasteAll, Transpose:=True)
End With
Application.CutCopyMode = False
Call objWorkbook.Close(SaveChanges:=False)
Set objWorkbook = Nothing
Set objTargetSheet = Nothing
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Gruss Torsten