AW: CSV Zellen Import auf andere Tabelle
15.10.2018 10:52:40
fcs
Hallo Anna,
der Fehler liegt am Ende des Makros.
Da fehlte 2 mal ein "Set", da es sich bei den Variablen um Objekt-Variablen handelt.
Das mit der Nummer bei der Auswahl der Datei mit der ERP-Liste funktioniert schon.
Intern setzt das Makro die Nummer ja wieder in den Namen um.
Ich hab das Makro jetzt eingekürzt auf den Fall, dass die Datei mit der ERP-Liste immer geöffnet ist.
So wird direkt die Input-Box zur Auswahl der Datei angezeigt.
LG
Franz
'Erstellt unter Office 365 - Excel Version 1809 / Windows 10
Sub Import_Resource_from_ERP_FIle()
Dim wkbQuelle As Workbook, wksQuelle As Worksheet, arrDatei()
Dim wksZiel As Worksheet
Dim Zeile_Z As Long, Zeile_Q As Long, StatusCalc As Long
Dim varInput, rngTest As Range
Dim sMsgTitel$, sMsgText$
sMsgTitel = "Resourcen aus ERP-Liste einlesen"
'Zieltabelle setzen
Set wksZiel = ThisWorkbook.Worksheets(1)
'letzte ausgefüllte Zeile in Spalte A der Zieltabelle ermitteln
With wksZiel
Zeile_Z = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
'Arrbeitsmappe mit ERP-Liste auswählen
' Datei mit ERP-Liste ist schon geöffnet
sMsgText = "Bitte Nummer der Datei auswählen"
'Namen der geöffneten Dateien in Array sammeln und für InputBox zusammenstellen
varInput = 0
For Each wkbQuelle In Application.Workbooks
If wkbQuelle.Windows(1).Visible = True _
And Not wkbQuelle.Name = ThisWorkbook.Name Then
varInput = varInput + 1
sMsgText = sMsgText & vbLf & varInput & " - " & wkbQuelle.Name
ReDim arrDatei(1 To varInput)
arrDatei(varInput) = wkbQuelle.Name
End If
Next
If varInput = 0 Then
sMsgText = "Es ist keine weitere Datei geöffnet!" & vbLf _
& "Dateiauswahl-Dialog anzeigen?"
MsgBox sMsgText, vbOKOnly, sMsgTitel
Else
'Inputbox zum Auswählen anzeigen
varInput = Application.InputBox(sMsgText, sMsgTitel, 1, Type:=1)
Select Case varInput
Case 0 'Abbrechen
Case 1 To UBound(arrDatei)
Set wkbQuelle = Application.Workbooks(arrDatei(varInput))
Case Else 'falsche Auswahl
End Select
End If
'Daten aus ERP-Liste übertragen
If Not wkbQuelle Is Nothing Then
'Makrobremsen lösen
With Application
.ScreenUpdating = False
StatusCalc = .Calculation 'Berechnungsmodus merken
.Calculation = xlCalculationManual
' .EnableEvents = False 'falls Ereignismakros blockiert werden sollen
End With
Set wksQuelle = wkbQuelle.Sheets(1)
With wksQuelle
'prüfen, ob Tabellenblatt in Spalte C Wort "Ressource" enthält.
varInput = "Ressource"
Set rngTest = .Range("C:C").Find(What:=varInput, LookIn:=xlValues, _
lookat:=xlWhole)
If rngTest Is Nothing Then
Application.ScreenUpdating = True
sMsgText = "Die ausgewählte Datei enthält in Spalte C von Blatt """ _
& .Name & """ nicht das Wort """ & varInput & """!"
MsgBox sMsgText, vbOKOnly + vbInformation, sMsgTitel
Else
'Werte aus ERP-Liste in Zielblatt übertragen
For Zeile_Q = 2 To .Cells(.Rows.Count, 3).End(xlUp).Row
If .Cells(Zeile_Q, 2).Value = "M" Then
Zeile_Z = Zeile_Z + 1
'Hochkomma in nächster Zeile stellt sicher, dass Inhalte _
aus Ziffern mit Punkt korrekt übertragen werden.
wksZiel.Cells(Zeile_Z, 1) = "'" & .Cells(Zeile_Q, 3).Text
End If
Next
End If
End With
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
.EnableEvents = True
End With
End If
Erase arrDatei
Set wkbQuelle = Nothing: Set wksQuelle = Nothing: Set wksZiel = Nothing
Set rngTest = Nothing
End Sub