|
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?
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 | Sub schreibe_in_Datei()
Dim i As Integer
fName = Dir("C:\Us<strong>ers\meyerj\Desktop\</strong>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<strong>:\Users\meyerj\Desktop\AV</strong>M\" '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]
w2 = Sheets(1).[L3]
w3 = Sheets(1).[B17]
w4 = Sheets(1).[B6]
w5 = Sheets(1).[L6]
w6 = Sheets(1).[B10]
w7 = Sheets(1).[L10]
w8 = Sheets(1).[B13]
w9 = Sheets(1).[L13]
w10 = Sheets(1).[L17]
w11 = Sheets(1).[K54]
w12 = Sheets(1).[J68]
w13 = Sheets(1).[N179]
w14 = Sheets(1).[L20]
w15 = Sheets(1).[B54]
w16 = Sheets(1).[H194]
w17 = Sheets(1).[H197]
w18 = Sheets(1).[H200]
w19 = Sheets(1).[H203]
w20 = Sheets(1).[H206]
w21 = Sheets(1).[H209]
w22 = Sheets(1).[J212]
w23 = Sheets(1).[H212]
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
|
|