|
Hallo,
also ich hab es nun getested. In meiner Echtdatei funktioniert zwar, aber das dauert fast fünf Minuten bis es durchgelaufen ist. In der Testfile geht es sofort.
Keine Ahnung, muss ich halt solange immer warten. Komisch
Hier der Code:
Dim wbStart As Workbook, wbZiel As Workbook
Dim lob As Excel.ListObject
Dim lobRow As Excel.ListRow
Dim rng As Excel.Range, rngIsect As Excel.Range
Dim x As Long
Application.ScreenUpdating = False
Worksheets("ExternBasis").Unprotect Password:="test"
If MsgBox("Willst du jetzt wirklich die Basisdaten in die Externe Datei übertragen? JA/NEIN", vbYesNo) = vbYes Then
If Worksheets("ExternBasis").Range("Q1").Value = "kopiert" Then
MsgBox ("Daten wurden bereits übertragen, transfer wird abgebrochen !!!")
Exit Sub
Else
Worksheets("ExternBasis").Activate
Worksheets("ExternBasis").Range("Q1").Value = "kopiert"
Set wbStart = ThisWorkbook
Set wbZiel = Workbooks.Open("O:\Produktionsbericht\Cute\Masterfiles\Masterfile_Jwb.xlsm")
Set lob = wbZiel.Worksheets(4).ListObjects("Tabelle3")
With wbStart.Worksheets("ExternBasis")
If .AutoFilterMode Then .AutoFilterMode = False
Set rng = .Range("A1:L" & .Cells(.Rows.Count, "L").End(xlUp).Row)
rng.AutoFilter Field:=8, Criteria1:="<>Leer"
Set rngIsect = Intersect(rng, rng.SpecialCells(xlCellTypeVisible), rng.Offset(1))
End With
If Not rngIsect Is Nothing Then
For x = 1 To rngIsect.Areas.Count Step 1
Set lobRow = lob.ListRows.Add
With lobRow
.Range.Resize(rngIsect.Areas(x).Rows.Count, rngIsect.Areas(x).Columns.Count).Value = rngIsect.Areas(x).Value
End With
Next x
End If
Workbooks("Masterfile_Jwb.xlsm").Activate
Workbooks("Masterfile_Jwb.xlsm").Close True
MsgBox "Übertragung erfolgreich !!!"
End If
Else
MsgBox "Vorgang abgebrochen"
End If
Worksheets("Zeiten").Activate
Worksheets("ExternBasis").Protect Password:="test"
|