@yummi: einzelne Dateien aus Ordner ansprechen
05.12.2017 21:39:44
arek
du hast letzte Woche schon nach einer Lösung für mich gesucht und deshalb wollte ich nochmal fragen, ob du dir das nochmal anschauen könntest...Es geht darum einzelne Dateien aus dem Ordner "TEST" anzusprechen. Dieser Code macht genau das was ich eig möchte für alle Dateien in dem Ordner, mein Ziel ist es aber eben das auf bestimmte Dateien zu begrenzen. Die Dateien in dem Ordner heißen alle "Name"_hours_booking...Vielen Dank im Voraus!
Option Explicit
Dim wkb As Workbook
Dim wksdata As Worksheet
Dim wksDest As Worksheet
Dim wkbData As Workbook
Sub Update_Button()
Dim llastr As Long
Dim ilasts As Integer
Dim z As Long
Dim s As Integer
Dim llastdest As Long
Dim Pfad As String
Dim Dateiname As String
Dim iRow As Long
Dim arr, na, b As Boolean
Dim FoundCells As Range
Pfad = "C:\Users\arek\Desktop\TEST\" 'Pfad, unter welchem die Stundenlisten liegen
Dateiname = Dir(Pfad & "*.xlsm")
Initialisiere 'Funktion Initialisiere siehe unten
On Error Resume Next
wksDest.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeConstants).Value = ""
On Error GoTo 0
Do While Dateiname "" 'Durchlaufen der Stundenlisten
Set wkbData = Workbooks.Open(Filename:=Pfad & Dateiname)
Set wksdata = wkbData.Sheets("Hours")
llastr = BestimmeLetzteZeile(wksdata, 2) 'letzte Zeile erstellen
ilasts = BestimmeLetzteSpalte(wksdata, 2) 'letzte Spalte bestimmen
llastdest = BestimmeLetzteZeile(wksDest, 1) + 1
If llastr > 2000 Then 'Stundenlisten nur bis Zeile 2000 durchlaufen
llastr = 2000
End If
For z = 5 To llastr 'Alle Zeilen ab Zeile 5 werden durchlaufen
For s = 3 To ilasts 'Alle Spalten ab Spalte C werden durchlaufen
If wksdata.Cells(z, s).Value "" Then
'Zeile kopieren und anschließender Übergang zur nächsten Stundenliste
wksDest.Cells(llastdest, 1).Value = wksdata.Cells(2, s).Value 'Belegdatum
wksDest.Cells(llastdest, 2).Value = wksdata.Cells(2, s).Value ' _
Buchungsdatum
wksDest.Cells(llastdest, 3).Value = wksdata.Cells(1, 1).Value ' _
Kostenstelle
wksDest.Cells(llastdest, 4).Value = wksdata.Cells(1, 3).Value ' _
Leistungsart
wksDest.Cells(llastdest, 6).Value = wksdata.Cells(z, 2).Value 'Projektname
wksDest.Cells(llastdest, 7).Value = wksdata.Cells(z, s).Value 'Menge
wksDest.Cells(llastdest, 8).Value = "H" 'ME
wksDest.Cells(llastdest, 9).Value = wksdata.Cells(1, 2).Value ' _
Personalnummer
llastdest = llastdest + 1
End If
Next s
Next z
wkbData.Close False
Set wksdata = Nothing
Set wkbData = Nothing
Dateiname = Dir() 'Automatische Auswahl der nächsten Datei
Loop
End Sub
Function BestimmeLetzteZeile(ByVal wks As Worksheet, ByVal s As Integer) As Long
BestimmeLetzteZeile = wks.Cells(wks.Rows.Count, s).End(xlUp).Row
End Function
Function BestimmeLetzteSpalte(ByVal wks As Worksheet, ByVal z As Long) As Integer
If wks.Cells(z, 1).Value "" Then
BestimmeLetzteSpalte = wks.Cells(z, wks.Columns.Count).End(xlToLeft).Column
Else
BestimmeLetzteSpalte = 1
End If
End Function
Function Initialisiere()
If wkb Is Nothing Then
Set wkb = ThisWorkbook
Set wksDest = wkb.Sheets("Tabelle1")
End If
End Function