Archivierung
19.02.2008 12:10:08
Julia
Und speichert diese in als daten.xls
führe ich das Makro erneut aus, wir die aktuelle daten.xls in den Ordner Archiv heschoben mit dem Datum des Vortags
Und die aktuelle soll die vorhandene überschreiben
Das Archvieren klappt aber er überschreibt mir die aktuelle nicht. wo liegt der Fehler?
Gruß Julia
Dim Pfad As String
Dim Pfadarchivierung As String
Dim Datum As String
Dim Kopie As String
Dim Original As String
Dim objFSO As Object
Sub Archivierung()
Set objFSO = CreateObject("Scripting.FileSystemObject")
Pfad = "H:\archiv2\" 'Variable für den Pfad - erspart mehrfaches ändern im Code
Pfadarchivierung = "H:\archiv2\\_Archiv\"
Original = "daten.xls" 'Variable für "Daten.xls"
Kopie = "_daten.xls.xls" 'Variable für "_Daten.xls"
With Application
.ScreenUpdating = False 'Bildschirmaktualisierung ausschalten
.EnableEvents = False 'Events abschalten
.DisplayAlerts = False 'Fehlermeldungen abschalten
End With
ChDir Pfad 'Verzeichnis wechseln aber eigentlich unnötig
Workbooks.Open (Pfad & Original) 'Daten.xls öffnen
If Weekday(Now) = 1 Or Weekday(Now) = 7 Then 'Prüfung auf Wochenende
Workbooks(Original).SaveAs (Pfadarchivierung & Date - 3 & Kopie) '"Alte" Daten.xls mit _
_
Datum vom Freitag speichern
Workbooks(Date - 3 & Kopie).Close 'Daten.xls mit Datum schliessen
Else
Workbooks(Original).SaveAs (Pfadarchivierung & Date - 1 & Kopie) '"Alte" Daten.xls mit _
_
Datum vom Vortag speichern
Workbooks(Date - 1 & Kopie).Close 'Daten.xls mit Datum schliessen
End If
Workbooks.Add
With ActiveSheet. _
">QueryTables.Add(Connection:=" _
URL;http://web.de/",
Destination:=Range("A1"))
.Name = "order=DESC&tempMax=2000&os_username=username&os_password=password"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = """issuetable"""
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Columns("F:F").Insert Shift:=xlToRight
Range("F1").FormulaR1C1 = "Status"
Range("F2:F1408").FormulaR1C1 = "=LEFT(RC[-1],LEN(RC[-1])/2)"
Columns("F:F").Copy
Columns("E:E").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, _
Transpose:=False
Columns("F:F").Delete Shift:=xlToLeft
Range("A1").Select
ActiveWorkbook.SaveAs (Pfad & Original) 'Neue Daten.xls über die alte speichern
Windows("Status Test_v0.6.xls").Activate
Windows(Original).Activate
ActiveWindow.Close
With Application
.ScreenUpdating = True 'Bildschirmaktualisierung anschalten
.EnableEvents = True 'Events anschalten
.DisplayAlerts = True 'Fehlermeldungen anschalten
End With
Set objFSO = Nothing
End Sub
Sub Archivierung_BaseData_Bugs_TestCoverage()
' AArchivierung_BaseData_Bugs_TestCoverage Makro
' Makro am 17.10.2007 von jaens01 aufgezeichnet
ChDir _
"H:\archiv2\"
Workbooks.Open Filename:= _
"H:\archiv2\Base+data+(Name+GmbH).xls"
ChDir _
"H:\archiv2\_Archiv"
ActiveWorkbook.SaveAs Filename:= _
"H:\archiv2\_Archiv\Base+data+(Name+GmbH).xls" _
, FileFormat:=xlHtml, ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWindow.Close
End Sub