ThisWorkbook.Path auf Netzlaufwerk

Chris · 2019-08-08T11:57:34+00:00

Hallo liebe Excel und VBA Gemeinde, könnt Ihr Euch mal bitte das Skript anschauen. Wenn ich es lokal ausführe funktioniert es. Wenn ich aber die Dateien auf ein Netzlaufwerk lege, schmiert Excel ab. Was muss ich ändern, damit das Skript auch auf Netzwerklaufwerken funktioniert? Als vertrauenwürdige Speicherorte sind die Netzlaufwerke hinzugefügt. Das Skript habe ich hier mit freundlicher Unterstützung von "EDE" erhalten und angepaßt. Wäre super, wenn Ihr mir weiterhelfen könnt! Hier das Skript: Sub t() Dim xl As Object, wb As Workbook, Counter As Long pfad = ThisWorkbook.Path & "\" Set xl = CreateObject("excel.application") ' für alle ID's aus Spalte A For i = 3 To Cells(Rows.Count, 1).End(xlUp).Row On Error Resume Next ' MsgBox pfad & Cells(i, 1) & ".xlsx" Set wb = xl.Workbooks.Open(Filename:=pfad & Cells(i, 1) & ".xlsx") Set ws = wb.Sheets(1) lz = ws.Cells(Rows.Count, 1).End(xlUp).Row For ii = 2 To lz If ws.Cells(ii, 1) = 1060 Then Cells(i, 4) = ws.Cells(ii, 4) Cells(i, 5) = ws.Cells(ii, 9) Exit For End If Next ii wb.Close False Set wb = Nothing Next i Set xl = Nothing xl.Quit End Sub

da sind ja die Kostenstellen auch nicht mehr in der Zeile 1, sondern in Zeile 2!!!
Dann teste mal jetzt diesen Code, wobei in der Variablen ZeileKoSt die Zeilennummer steht.


Sub t2()
Dim xl As Object, wb As Workbook
Dim pfad As String
Dim i As Long, ii As Long, lz As Long, sp As Long, lsp As Long
Dim myws As Worksheet, ws As Worksheet
Dim strFilename As String
Dim zeileKoSt As Long
'Blattname evtl. anpassen
Set myws = ActiveWorkbook.Sheets("Sheet1")
zeileKoSt = 2
pfad = ThisWorkbook.Path & "\"
Set xl = CreateObject("excel.application")
lsp = myws.Cells(zeileKoSt, Columns.Count).End(xlToLeft).Column  'letzte Spalte in 'Übersicht'
' für alle ID's aus Spalte A
For i = 3 To myws.Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
'Prüfe ob Datei existiert
strFilename = pfad & myws.Cells(i, 1) & ".xlsx"
If Dir(strFilename) = "" Then
MsgBox strFilename & "fehlt!", vbCritical, "Fehler"
Else
'DAtei öffnen
Set wb = xl.Workbooks.Open(Filename:=strFilename)
Set ws = wb.Sheets(1)
lz = ws.Cells(Rows.Count, 1).End(xlUp).Row   'letzte Zeile in akt. Datendatei
' für alle Spalten der Zeile 'zeileKoST' im 2er-step
For sp = 4 To lsp Step 2
'für alle Zeilen der Spalte 1(A) der Datendatei
For ii = 3 To lz
If ws.Cells(ii, 1) = myws.Cells(zeileKoSt, sp) Then
myws.Cells(i, sp) = ws.Cells(ii, 4)
myws.Cells(i, sp + 1) = ws.Cells(ii, 9)
End If
Next ii
Next sp
wb.Close False
Set wb = Nothing
End If
Next i
Set xl = Nothing
'xl.Quit
End Sub

Gruss
ede

Hallo Chris,
anbei mal der angepasste Code: die Ursache lag darin, das in der Zelle D4 die Kostenstellennummer und Kostenstellenbezeichnung steht. In den einzelnen Datendateien aber nur die KoST-nummer. Ich hab den Code jetzt so angepasst und in ein Modul gelegt.
https://www.herber.de/bbs/user/131333.xlsm


Sub t2()
Dim xl As Object, wb As Workbook
Dim pfad As String
Dim i As Long, ii As Long, lz As Long, sp As Long, lsp As Long
Dim myws As Worksheet, ws As Worksheet
Dim strFilename As String
Dim zeileKoSt As Long
Dim startzeile As Long
'Blattname evtl. anpassen
Set myws = ActiveWorkbook.Sheets("Sheet1")
zeileKoSt = 2
startzeile = 4
pfad = ThisWorkbook.Path & "\"
Set xl = CreateObject("excel.application")
lsp = myws.Cells(zeileKoSt, Columns.Count).End(xlToLeft).Column  'letzte Spalte in 'Übersicht'
' für alle ID's aus Spalte A
For i = startzeile To myws.Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
'Prüfe ob Datei existiert
strFilename = pfad & myws.Cells(i, 1) & ".xlsx"
If Dir(strFilename) = "" Then
MsgBox strFilename & " fehlt!", vbCritical, "Fehler"
Else
'DAtei öffnen
Set wb = xl.Workbooks.Open(Filename:=strFilename)
Set ws = wb.Sheets(1)
lz = ws.Cells(Rows.Count, 1).End(xlUp).Row   'letzte Zeile in akt. Datendatei
' für alle Spalten der Zeile 'zeileKoST' im 2er-step
For sp = 4 To lsp Step 2
'für alle Zeilen der Spalte 1(A) der Datendatei
For ii = 3 To lz
If ws.Cells(ii, 1) = Val(Left(myws.Cells(zeileKoSt, sp), 4)) Then
myws.Cells(i, sp) = ws.Cells(ii, 4)
myws.Cells(i, sp + 1) = ws.Cells(ii, 9)
End If
Next ii
Next sp
wb.Close False
Set wb = Nothing
End If
Next i
Set xl = Nothing
'xl.Quit
End Sub

gruss
ede

ThisWorkbook.Path auf Netzlaufwerk

Forumthread: ThisWorkbook.Path auf Netzlaufwerk

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial