save wb - dringend | HERBERS Excel Forum

Hallo,
ich habe eine ganz einfache aufgabe aber schaffe es einfach nicht.
Ich will alle dateien in einem ordner öffnen.
Bei jeder datei soll im sheet1 die Spalte K kopiert werden
ein template wb soll geöffnet werden.
Die funktion anzahl2 soll in zeile 5 durchgeführt werden. Dann addiere ich 2 dazu um die nächste freie spalte zu erhalten.
dann die kopierte Zellen einfügen
das Template unter einem neuen namen abspeichern
Das wars. Aber ich kann nicht speichern. Es kommt immer der fehler zugriff auf das schreibgeschützt dokument nicht möglich. aber die datei ist nicht schreibgeschützt.
PS: Ich bin mit MAcOS unterwegs.
Über eine Hilfe freue ich mich. Ich muss das heute noch zum laufen bringen.

Sub OpenAllWorkbooks()
    'Step 1:Declare your variables
    Dim MyFiles, file, groupe As String
    'Step 2: Specify a target folder/directory, you may change it.
    groupe = "Agricultural"
    file = "/Users/js/Desktop/" & groupe & "/"
    MyFiles = Dir(file & "*.xlsx")
    getparentdirectory = Left(MyFiles, InStrRev(MyFiles, "/"))
    Debug.Print ("parent:" & groupe & "       file:" & file & "       myfile:" & MyFiles)
    Do While MyFiles > ""
        'Step 3: Open Workbooks one by one
        Set wb_source = Workbooks.Open(file & MyFiles)
        wb_source.Sheets(1).Range("K:K").Copy
        Set mybook2 = Workbooks.Open("/Users/js/Documents/template.xlsx")
        mybook2.Sheets(1).Activate
        myCount = WorksheetFunction.CountA(Range("5:5")) + 2
        Debug.Print ("function" & WorksheetFunction.CountA(Range("5:5")))
        Debug.Print ("mycount: " & myCount)
        mybook2.Sheets(1).Cells(1, myCount).PasteSpecial Paste:=xlPasteValues
        newfilename = groupe & "summary sheet"
        ActiveWorkbook.SaveAs FileName:=newfilename
        wb_source.Close
    Loop
    Debug.Print ("Fertig")
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub OpenAllWorkbooks() Dim MyFile As String, sPath As String, groupe As String Dim mybook2 As Workbook, sh2 As Worksheet, lastcol&, rng As Range 'Dim getparentdirectory Application.ScreenUpdating = False groupe = "Agricultural" sPath = "/Users/js/Desktop/" & groupe & "/" 'getparentdirectory = Left(MyFiles, InStrRev(MyFiles, "/")) Set mybook2 = Workbooks.Open(Filename:="/Users/js/Documents/template.xlsx", Editable:=True) lastcol = mybook2.Sheets(1).Cells(5, Columns.Count).End(xlToLeft).Column MyFile = Dir(sPath & "*.xlsx") Do While MyFile > "" With Workbooks.Open(sPath & MyFile) With .Sheets(1) Set rng = Intersect(.UsedRange, .Range("K:K")) mybook2.Sheets(1).Cells(1, lastcol + 2).Resize(rng.Rows.Count, 1).Value = rng.Value lastcol = lastcol + 2 .Parent.Close End With End With MyFile = Dir() Loop mybook2.SaveAs Filename:=sPath & "summary sheet" mybook2.Close Application.ScreenUpdating = True Debug.Print ("Fertig") End Sub

Beliebteste Forumthreads (12 Monate)

save wb - dringend

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread