Endlosschlaufe beim Öffnen aus Folder
07.01.2020 18:53:00
Patricia
Ich bin ganz neu hier.
Ich versuche eine Prozedur zu erstellen, um Files aus einem Folder auszulesen, einen Bereich zu kopieren von einem ws in ein anderes und File wieder schliessen (speichern in einem anderen Pfadt).
Es läuft eigentlich gut, ausser dass ich eine Endlosschlaufe habe.
Habe schon mal ab Celle C2 das Probefile ausgelesen (Namen), evtl. könnte man damit was machen anstatt mit den fname?
Aber ich bin noch zu schwach im VBA und das selber herauszufinden, und ich habe schon lange genug geübt bis ich diesen Code hatte... sorry.
Wäre toll wenn mir jemand helfen könnt! Ist sicher sehr kompliziert geschrieben von mir..
Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim wbThis As Workbook 'workbook where range and path is stored
Dim wbTarget As Workbook 'workbook from where the data is to be copied from, _
_
_
_
(aka Overnights file)
Dim OpenPath As String
OpenPath = Sheets("Sheet1").Range("B1").Value ' Path wo Files gespeichert sind
Dim SavePath As String
SavePath = Sheets("sheet1").Range("b6") ' Path wo Files gespeichert sind
Dim rngCopy As String ' Bereich der kopiert werden soll
rngCopy = Sheets("sheet1").Range("b2").Value
Dim ss As Worksheet '1st Worksheet where copy range is ==>source sheet
Dim ds As Worksheet '2nd Worksheet where range shall be copied to ==> _
_
_
_
destination sheet
Dim namess As String 'get value/name of source sheet in cell b4
Dim nameds As String 'get value/name of destination sheet in b5
namess = Sheets("Sheet1").Range("b4").Value
nameds = Sheets("Sheet1").Range("b5").Value
Set wbThis = ActiveWorkbook ''set to the current active workbook (the source book, the Master!)
Dim SaveNameStart As String
SaveNameStart = Sheets("Sheet1").Range("B7").Value ' die ersten 5 Zeichen für den neuen _
Filenamen
Dim NewFileName As String
Fname = Dir(OpenPath)
Do While Fname ""
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Set wbTarget = Workbooks.Open(filename:=OpenPath & Fname)
Sheets(namess).Range(rngCopy).Copy
Sheets(nameds).Range("a10").PasteSpecial Paste:=xlPasteAll
Sheets(nameds).Range("A10").Select
NewFileName = Sheets(namess).Range("d1").Value & Sheets(namess).Range("d2").Value _
& Sheets(namess).Range("d3").Value 'get file name (concatenate) from period in macro file _
_
_
_
and various cells in target wb
wbTarget.SaveAs filename:=SavePath & SaveNameStart & NewFileName & ".xlsx"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
'close the overnight's file
wbTarget.Close
wbThis.Activate
Loop
End Sub