|
Hallo, Ich würde gerne sehr viele Dateien auslesen und Werte in die Arbeitsmappe schreiben. dass klappt sehr gut. (Sie formel)
Einziges Problem: der Dateipfad kann sich ändern. die Analysedatei liegt im selben ordner wie die einzeldateien.
Könnte jemand einen Tipp geben, wie Ich den code umschreiben muss um unabhängig vom speicherort des ordners in dem alle dateien liegen zu werden?
Sub schreibe_in_Datei()
Dim i As Integer
fName = Dir("C:\Users\meyerj\Desktop\AVM\*.xlsx") 'den Pfad musst Du anpassen!!! fName = Dir("C:\Users\meyerj\Desktop\AVM\*.xlsx")
Call newRecord(fName)
Do
fName = Dir
Call newRecord(fName)
Loop While fName <> ""
End Sub
Sub newRecord(fName)
If fName = ThisWorkbook.Name Or fName = "" Then
Exit Sub
End If
Dim ab As Workbook
Dim sh As Worksheet
Dim c As Object
Dim ze As Long
Dim fPath
Set wb = ThisWorkbook
Set sh = wb.Sheets("Tabelle1")
fPath = "C:\Users\meyerj\Desktop\AVM\" 'Den Pfad musst Du anpassen!!! fPath = "C:\Users\meyerj\Desktop\AVM\"
ze = sh.[A666].End(xlUp).Row + 1
Workbooks.Open Filename:=fPath & fName
w1 = Sheets(1).[B3] 'Pr Nr
w2 = Sheets(1).[L3] 'Pr bez
w3 = Sheets(1).[B17] 'V EK
w4 = Sheets(1).[B6] 'Nom lief
w5 = Sheets(1).[L6] 'Kred Nr.
w6 = Sheets(1).[B10] 'Art bez
w7 = Sheets(1).[L10] 'Artnr
w8 = Sheets(1).[B13] 'index
w9 = Sheets(1).[L13] 'Bespr dat
w10 = Sheets(1).[L17] 'PSP Element
w11 = Sheets(1).[K54] 'Befürwortung PU-SM
w12 = Sheets(1).[J68] 'Befürwortung PU-TE
w13 = Sheets(1).[N179] 'Logistik Vllständig
w14 = Sheets(1).[L20] 'Dokument vollständig
w15 = Sheets(1).[B54] 'SQE
w16 = Sheets(1).[H194] 'Entwurf
w17 = Sheets(1).[H197] 'Zchng
w18 = Sheets(1).[H200] 'HSB
w19 = Sheets(1).[H203] 'VP
w20 = Sheets(1).[H206] 'Kapa
w21 = Sheets(1).[H209] 'Datum
w22 = Sheets(1).[J212] 'PPAP Datum
w23 = Sheets(1).[H212] 'Anfzbem
ActiveWorkbook.Close savechanges:=False
sh.Cells(ze, 1) = w1
sh.Cells(ze, 2) = w2
sh.Cells(ze, 3) = w3
sh.Cells(ze, 4) = w4
sh.Cells(ze, 5) = w5
sh.Cells(ze, 6) = w6
sh.Cells(ze, 7) = w7
sh.Cells(ze, 8) = w8
sh.Cells(ze, 9) = w9
sh.Cells(ze, 10) = w10
sh.Cells(ze, 11) = w11
sh.Cells(ze, 12) = w12
sh.Cells(ze, 13) = w13
sh.Cells(ze, 14) = w14
sh.Cells(ze, 15) = w15
sh.Cells(ze, 16) = w16
sh.Cells(ze, 17) = w17
sh.Cells(ze, 18) = w18
sh.Cells(ze, 19) = w19
sh.Cells(ze, 20) = w20
sh.Cells(ze, 21) = w21
sh.Cells(ze, 22) = w22
sh.Cells(ze, 23) = w23
Exit Sub
fb_find:
If Err = 91 Then
Resume Next
Else
MsgBox "Fehler Nr. " & Err & " ist aufgetreten:" & vbCr & Error
End If
End Sub
|