Daten importieren und auflisten
11.07.2016 08:33:38
Rookie
und wieder stehe ich vor einem Problem und verstehe nicht warum es nicht funktioniert:
Ich habe einen Code mit dem ich Daten aus anderen Excel-Dateien auslese und in bestimmte Zellen eintrage. Funktioniert super, aber nur dann, wenn ab der ersten Zeile mit dem Datenimport begonnen wird. Ich möchte aber, dass der Import ab der zweiten Zeile beginnt, da ich noch Überschriften einfügen möchte.
Der Datenimport läuft durch, aber hört nicht nach dem letzten Datensatz auf und bringt mir den Laufzeitfehler 13 - Typen unverträglich.
Hier der Code, vielleicht wisst ihr wo der Fehler liegt:
Sub Datensuche()
Dim vntRet As Variant, strTMP As String
Dim pfad As String, ausgabe$()
Dim i&, p&
'Ordner und Suchbegriff festlegen
pfad = "R:\bereich35000\2016"
If Right(pfad, 1) "\" Then pfad = pfad & "\"
strTMP = CreateObject("wscript.shell").exec("cmd /c Dir """ _
& pfad & "Maßnahmenplan*.xlsm" & """ /s /b").stdout.readall
Call OemToCharA(strTMP, strTMP)
vntRet = Split(strTMP, vbCrLf)
'Zellen leeren, Zähler aktivieren und Links ausgeben
If UBound(vntRet) > 0 Then
Master.Range("A2:P50").ClearContents
ReDim ausgabe(1 To UBound(vntRet) + 1, 1 To 1)
For i = 0 To UBound(vntRet)
ausgabe(i + 1, 1) = vntRet(i)
Next
If ausgabe(UBound(ausgabe), 1) = "" Then p = 1 Else p = 0
Master.Range("B2").Resize(UBound(ausgabe) - p, 1) = ausgabe
ReDim vntRet(1 To UBound(ausgabe) - p, 0)
For i = 1 To UBound(vntRet): vntRet(i, 0) = i: Next
Master.Range("A2").Resize(UBound(ausgabe) - p, 1) = vntRet
End If
'Daten auslesen und eintragen
Dim datein As Variant, dIN As Variant, dOut As Variant
Dim aWB As Workbook
Dim mDL&, mD&, mImp&, v&, z&, dl&, fehler As Boolean
mDL = Master.Range("B" & Master.Rows.Count).End(xlUp).Row
mD = Master.Range("C" & Master.Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
If mD > 2 Then Master.Rows("3:" & mD).ClearContents
mD = 3
dOut = Master.Range("C2:P2")
datein = Master.Range("B2").Resize(mDL + 1)
For v = 1 To mDL
If Dir(datein(v, 1)) "" Then
fehler = False
On Error Resume Next
Workbooks.Open datein(v, 1), False, True
If Err 0 Then
Master.Range("C" & v) = Err.Description
fehler = True
End If
On Error GoTo 0
If Not fehler Then
Set aWB = ActiveWorkbook
dIN = aWB.Sheets(1).UsedRange
aWB.Close savechanges:=False
dOut(1, 1) = v ' Laufende Nummer
dOut(1, 2) = dIN(5, 20) ' Berichtnummer
dOut(1, 3) = dIN(3, 8) ' LC
dOut(1, 4) = dIN(4, 8) ' AEP
dOut(1, 5) = dIN(5, 8) ' Kostenstelle
dOut(1, 6) = dIN(6, 8) ' Produktgruppe
dOut(1, 8) = dIN(4, 16) ' Maßnahmenkoordinator
dOut(1, 9) = dIN(6, 20) ' Auditor
dOut(1, 10) = dIN(4, 20) ' Rückmeldetermin
dOut(1, 12) = dIN(8, 20) ' Audit Abschlusstermin
dOut(1, 7) = dIN(4, 28) ' ABC-Einstufung
dOut(1, 14) = dIN(7, 31) ' Wirksamkeit offen
dOut(1, 11) = dIN(3, 32) ' Rückmeldung Maßnahmen
dOut(1, 13) = dIN(4, 32) ' Rückmeldung Wirksamkeit
Master.Range("C" & v + 1).Resize(, 14) = dOut
End If
End If
Next
Set aWB = Nothing
Columns("D:D").Select
ActiveWorkbook.Worksheets("Tabelle1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Tabelle1").Sort.SortFields.Add Key:=Range("D1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Tabelle1").Sort
.SetRange Range("A1:Y19")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Text wird in Hyperlink umgewandelt
Dim x As Long
For x = 1 To i - 1
With Master
.Hyperlinks.Add Anchor:=.Range("B" & x), Address:=.Range("B" & x).Value, ScreenTip:=.Range("B" _
_
_
_
& x).Value, TextToDisplay:="Maßnahmenplan öffnen"
End With
Next x
ActiveWorkbook.Worksheets("Tabelle1").Range("A1").Select
End Sub
Vielen Dank für eure Hilfe!!!
Mit besten Grüßen
Stefan