25.10.2017, 09:25
Hallo,
ich habe ein Makro, welches Dateien aus zwei Unterordner öffnen und sich von dort Daten ziehen soll.
Es kommt aber zu folgendem Problem:
Beim ersten ausführen zieht er sich alle Infos aus dem zweiten Ordner und nur die Daten aus der letzten Datei aus dem ersten Ordner.
Beim zweiten Durchlauf ist es dann umgekehrt
Hat jemand ne Idee?
ich habe ein Makro, welches Dateien aus zwei Unterordner öffnen und sich von dort Daten ziehen soll.
Es kommt aber zu folgendem Problem:
Beim ersten ausführen zieht er sich alle Infos aus dem zweiten Ordner und nur die Daten aus der letzten Datei aus dem ersten Ordner.
Beim zweiten Durchlauf ist es dann umgekehrt
Hat jemand ne Idee?
Code:
Sub an()
Dim FolderPathF As String, FolderPathUC As String, pathF As String, count As Integer, countUC As Integer, i As Integer, wks As Worksheet, ws As Worksheet, lrow As String, lrowUC As String, QG As String, j As Integer, x As Integer, y As Integer
FolderPathF = ActiveWorkbook.Path & "\Funding\"
FolderPathUC = ActiveWorkbook.Path & "\Unit Cost\"
'Abfrage QG
QG = "QG " & InputBox("Welches QG soll geladen werden?")
'MsgBox QG
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
pathF = FolderPathF & "\*.xlsx"
pathUC = FolderPathUC & "\*.xlsx"
'GoTo jump
Filename = Dir(pathF)
Do While Filename <> ""
count = count + 1
Filename = Dir()
Loop
For i = 1 To count
Set wkbCopy = Workbooks.Open(FolderPathF & i & ".xlsx", UpdateLinks:=0)
Worksheets("Funding " & QG).Activate
lrow = Cells(Rows.count, 8).End(xlUp).Row
lrow = "H8:AO" & lrow
Worksheets("Funding " & QG).Range(lrow).Copy
'Zurück zur "eigentlichen" Datei. Neues Blatt plus einfügen
Application.ThisWorkbook.Activate
'letzte Zeile ausfindig machen
lrow = Cells(Rows.count, 8).End(xlUp).Row + 3
'Cells(lrow, 8) = i & ".xlsx"
'in die letzte Zeile einfügen
Worksheets("Funding").Cells(lrow + 1, 8).PasteSpecial (xlPasteValues)
'Blatt schließen ohne Speichern und ohne Zwischenablage
Application.CutCopyMode = False
Workbooks(i & ".xlsx").Close savechanges:=False
Cells(lrow, 8).Font.Bold = True
Next i
Filename = Dir(pathUC)
Do While Filename <> ""
countUC = countUC + 1
Filename = Dir()
Loop
For j = 1 To countUC
Set wkbCopy = Workbooks.Open(FolderPathUC & j & ".xlsx", UpdateLinks:=0)
Worksheets("Unit Cost " & QG).Activate
lrowUC = Cells(Rows.count, 6).End(xlUp).Row
lrowUC = "F8:AO" & lrowUC
Worksheets("Unit Cost " & QG).Range(lrowUC).Copy
'Zurück zur "eigentlichen" Datei. Neues Blatt plus einfügen
Application.ThisWorkbook.Activate
'letzte Zeile ausfindig machen
lrowUC = Cells(Rows.count, 8).End(xlUp).Row + 2
'Cells(lrowUC, 6) = j & ".xlsx"
'in die letzte Zeile einfügen
Worksheets("Unit Cost (Input)").Cells(lrowUC + 1, 6).PasteSpecial (xlPasteValues)
'Blatt schließen ohne Speichern und ohne Zwischenablage
Application.CutCopyMode = False
Workbooks(j & ".xlsx").Close savechanges:=False
Cells(lrowUC, 6).Font.Bold = True
Next j
Call F
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox count & " Funding-Datein verarbeitet" & vbNewLine & countUC & " Unit Cost-Datein verarbeitet"
End Sub