+- Office-Fragen.de (https://office-fragen.de)
+-- Forum: Microsoft Office (https://office-fragen.de/forum-1.html)
+--- Forum: Excel (https://office-fragen.de/forum-2.html)
+--- Thema: Umbenennen einer Datei (/thread-4611.html)
Umbenennen einer Datei - Niko - 22.11.2019
Hallo Zusammen ich bin dabei ein Makro zu erstellen bei dem ich eine Datei aus dem Internet herunterlade und diese dann weiter verarbeitet. Unteranderem wird die Datei entpackt und diese entpackte Datei wird dann später umbenannt. Meint Code funktioniert eigentlich soweit wenn ich den Code händisch Schritt für Schritt per F8 durchgehe. Führe ich den Gesamten Code aus bleibt der Code an der Stelle, an der ich die Datei umbenenne stehen. Jetzt kommt der kuriose Part. Drücke ich ein Weiteres mal auf F5 bzw. Fortsetzen wird der Code bis zum Ende durchgeführt wie ich es mir vorstelle.
Public Sub Umbenennen()
Do
NameUrsprung = DownloadOrdner & DateiExist
Loop Until NameUrsprung <> ""
DateiName = Left(DateiExist, Len(DateiExist) - 4)
Do
NameZiel = DownloadOrdner & DateiName & ".txt"
Loop Until NameZiel <> ""
'Name NameUrsprung As NameZiel <-Hier tritt der Fehler auf
Name "C:\HSNR\ELMAR\Wärmenetz\Test_Ordner\MOSMIX_L_2019112209_N8527.kml" As "C:\HSNR\ELMAR\Wärmenetz\Test_Ordner\MOSMIX_L_2019112209_N8527.txt"
End Sub
Der Fehler tritt an der markierten Zeile auf, die immoment auskommentiert ist. Ich habe diese schon versucht dadrunter mit den "richtigen" Pfaden also ohne Variablen zu ersetzten aber auch dann tritt der Fehler auf. Mein Gedanke war an dieser Stelle, dass etwas mit den Variablen nicht stimmt aber diese sind zu dem Zeitpunkt als der Code stehen bleibt so definiert wie sie sein sollen. Die ganze Prozedur wird an einer anderen Stelle aufgerufen.
Der Fehler ist übrigens "Laufzeitfehler 75 Fehler beim Zugriff auf Pfad Datei"
Ich finde einfach keine Lösung, da der Fehler ja kein "harter" Fehler ist und durch Fortsetzen des Codes einfach behoben wird. Vielleicht könnte mir jemand Helfen. Ich bin für jeden Rat im Voraus dankbar!
Niko
RE: Umbenennen einer Datei - maninweb - 22.11.2019
Hallo,
Du könntest versuchen, statt Name eine Kombination von FileCopy und Kill zu nehmen.
Code:
FileCopy Quelldatei, Zieldatei (beides inkl. Pfad)
Kill QuelldateiGgf. nach FileCopy die Existenz der kopierten Datei prüfen (mit Dir) und erst dann die Quelldatei löschen.
Gruß
RE: Umbenennen einer Datei - Niko - 22.11.2019
Danke für den Tipp, ich habe aufjedenfall neue Befehle kennengelertn. Leider funktioniert auch dieser Code nicht fehlerfrei denn diesmal bekomm ich den Fehler : "Laufzeitfehler 70: Zugriff verweigert", was aber auch wieder komisch ist, dass durch nochmaliges Fortsetzen des Codes der Fehler wieder ignoriert wird und der Code bis zum Ende wie gewünscht weiter läuft.
Hier ist mein gesamter Code, vielleicht liegt ja auch irgendwo anders das Problem.
Dim DateiName As String
Dim Zeit1 As Date
Dim Zeit2 As String
Dim Datum1 As Date
Dim Datum2 As String
Dim dieUrl As String
Dim DateiPfadzip As String
Dim myResult
Dim StationsID As String
Dim Zählen1 As Integer
Dim Zählen2 As Integer
Dim Zählen3 As Integer
Dim Zählen4 As Integer
Dim Zählen5 As Integer
Dim strFileName As String
Dim DateiExist As String
Dim DateiNameZip As String
Dim DateiNameTxt As String
Dim Name As String
Dim Test As String
Dim DownloadOrdner As String
Dim Pfad As String
Dim NameUrsprung As String
Dim NameZiel As String
Dim Laufdatei As String
Dim ArchivOrdner As String
Option Explicit
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
Sub Prognose()
Datum1 = Date 'aktuelles Datum wird in einer Datum Variable gespeichert
Datum2 = Format(Datum1, "YYYYMMDD" & "09") 'aktuelles Datum wird in einem String gespeichert
StationsID = Sheets("Rechner2").Cells(20, 4) 'Die StationsId wird in einer Variable gespeichert
Zeit1 = Format(Now, "h:mm
s") 'aktuele Uhrzeit wird in einer Zeit Variable gespeichertZeit2 = Format(Zeit1, "hmmss") 'aktuele Uhrzeit wird in einem String gespeichert
Call GetExcelfolder
'DownloadOrdner = "C:\HSNR\ELMAR\Wärmenetz\Test_Ordner\"
Do
Zählen1 = Zählen1 + 1
Loop Until DownloadOrdner <> ""
Call Ordner
Call Download
Do
Zählen2 = Zählen2 + 1
DateiExist = Dir(DownloadOrdner)
DateiNameZip = DateiExist
Loop Until DateiExist <> ""
Name DownloadOrdner & DateiNameZip As ArchivOrdner & DateiNameZip
Do
Zählen3 = Zählen3 + 1
Loop Until Dir(ArchivOrdner & DateiExist) <> ""
Call Packen
Do
DateiExist = ""
DateiExist = Dir(DownloadOrdner)
DateiNameTxt = DateiExist
Zählen4 = Zählen4 + 1
Loop Until DateiExist <> ""
Call Umbenennen
DateiExist = ""
Do
Zählen5 = Zählen5 + 1
DateiExist = Dir(DownloadOrdner)
DateiNameTxt = DateiExist
Loop Until DateiExist = DateiName & ".txt"
Call Importieren
Call Sheetadd
Name DownloadOrdner & DateiNameTxt As ArchivOrdner & DateiName & Zeit2 & ".txt"
End
End Sub
Public Sub Download()
dieUrl = "https://opendata.dwd.de/weather/local_forecasts/mos/MOSMIX_L/single_stations/" & StationsID & "/kml/MOSMIX_L_LATEST_" & StationsID & ".kmz"
DateiPfadzip = DownloadOrdner & "\MOSMIX_L_LATEST_" & Datum2 & "_" & StationsID & "_" & Zeit2 & ".zip"
myResult = URLDownloadToFile(0, dieUrl, DateiPfadzip, 0, 0)
End Sub
Sub Packen()
Pfad = "C:\Programme\WinRAR\WinRAR.exe e " & ArchivOrdner & DateiExist & " " & DownloadOrdner
Shell (Pfad)
End Sub
Public Sub Umbenennen()
Do
NameUrsprung = DownloadOrdner & DateiExist
Loop Until NameUrsprung <> ""
DateiName = Left(DateiExist, Len(DateiExist) - 4)
Do
NameZiel = DownloadOrdner & DateiName & ".txt"
Loop Until NameZiel <> ""
FileCopy NameUrsprung, NameZiel
Kill NameUrsprung
'FileCopy "C:\HSNR\ELMAR\Wärmenetz\Test_Ordner\MOSMIX_L_2019112209_N8527.kml", "C:\HSNR\ELMAR\Wärmenetz\Test_Ordner\MOSMIX_L_2019112209_N8527.txt"
'Kill "C:\HSNR\ELMAR\Wärmenetz\Test_Ordner\MOSMIX_L_2019112209_N8527.kml"
'Name "C:\HSNR\ELMAR\Wärmenetz\Test_Ordner\MOSMIX_L_2019112209_N8527.kml" As "C:\HSNR\ELMAR\Wärmenetz\Test_Ordner\MOSMIX_L_2019112209_N8527.txt"
'Name "C:\HSNR\ELMAR\Wärmenetz\Test Ordner\MOSMIX_L_2019111309_N8527.kml" As "C:\HSNR\ELMAR\Wärmenetz\Test Ordner\MOSMIX_L_2019111309_N8527.txt"
End Sub
Sub Importieren()
Workbooks.OpenText Filename:=NameZiel, _
Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), _
Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1)), TrailingMinusNumbers _
:=True
End Sub
Public Function GetExcelfolder() As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Bitte Ordner wählen"
.InitialFileName = "C:\"
.InitialView = msoFileDialogViewThumbnail
.ButtonName = "OK"
If .Show = -1 Then
GetExcelfolder = .SelectedItems(1)
End If
DownloadOrdner = GetExcelfolder & "\"
End With
End Function
Sub Sheetadd()
Windows(DateiExist).Activate
Sheets(DateiName).Select
Sheets(DateiName).Copy After:=Workbooks( _
"Berechnung_Wärmenetz(Beta_V6)xlsb.xlsm").Sheets(9)
Workbooks(DateiExist).Close SaveChanges:=False
End Sub
Sub Ordner()
ArchivOrdner = DownloadOrdner & "Archiv\"
If Dir(ArchivOrdner, vbDirectory) = "" Then
MkDir (ArchivOrdner)
Else
End If
End Sub
RE: Umbenennen einer Datei - maninweb - 24.11.2019
Hallo,
ich habe Dir das mal komplett umgeschrieben, da bei Dir nun doch einiges an Fehlern und unnötiger Code drin ist.
Du musst dann entsprechend Anpassungen an Deine Gegebenheiten vornehmen. Den Code in ein neues Modul
kopieren und Deine alte Prozedur Prognose umbenennen.
Code:
Option Explicit
' API...
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
' Konstanten...
Private Const cstFolderArchive As String = "Archiv"
Private Const cstFolderDefault As String = "D:\Downloads\Niko"
' Private...
Private Function GetFolder(Default As String, Override As Boolean) As String
Dim r As String
' Übergehen...
If Not Override Then
' Dialog aufrufen...
With Application.FileDialog(msoFileDialogFolderPicker)
' Einstellungen..
.AllowMultiSelect = False
.Title = "Bitte Ordner wählen"
.InitialFileName = cstFolderDefault
.InitialView = msoFileDialogViewThumbnail
.ButtonName = "OK"
' Anzeigen...
If .Show = -1 Then
r = .SelectedItems(1)
End If
End With
End If
' Standardordner falls abgebrochen oder übergangen...
If Len(r) < 1 Then
r = Default
End If
' Return...
GetFolder = r
End Function
Public Function Unzip(Source As Variant) As String
Dim objShell As Object
Dim objSource As Object
Dim objTarget As Object
Dim objItem As Object
Dim strResult As String
Dim strSeparator As String
Dim vntFolder As Variant
' Fehler...
On Error Resume Next
' Initialisieren...
strResult = ""
strSeparator = Application.PathSeparator
vntFolder = Left(Source, Len(Source) - Len(Split( _
StrReverse(Source), strSeparator)(0)))
' Shell..
Set objShell = CreateObject("Shell.Application")
' Prüfen...
If Not objShell Is Nothing Then
' Namespaces...
Set objSource = objShell.Namespace(Source)
Set objTarget = objShell.Namespace(vntFolder)
' Prüfen...
If Not objSource Is Nothing And _
Not objTarget Is Nothing Then
' Anzahl...
If objSource.Items.Count > 0 Then
' Erstes Element...
strResult = objSource.Items.Item(0).Name
' Löschen...
If Not UCase(Dir(vntFolder & strSeparator & strResult)) <> _
UCase(strResult) Then
Kill vntFolder & strSeparator & strResult
End If
' Nicht vorhanden oder erfolgreich gelöscht...
If UCase(Dir(vntFolder & strSeparator & strResult)) <> _
UCase(strResult) Then
objTarget.CopyHere objSource.Items.Item(0)
End If
End If
End If
End If
' Aufräumen...
Set objTarget = Nothing
Set objSource = Nothing
Set objShell = Nothing
' Ergebnis...
Unzip = strResult
End Function
' Public...
Public Sub Prognose()
Dim lngError As Long
Dim lngResult As Long
Dim strArchive As String
Dim strDate As String
Dim strDownload As String
Dim strFile As String
Dim strFileKML As String
Dim strFileText As String
Dim strSeparator As String
Dim strStation As String
Dim strTime As String
Dim strUrl As String
' Initialisieren...
lngError = 0
strDate = Format(Date, "YYYYMMDD") & "09"
strTime = Format(Time, "hhmmss")
strSeparator = Application.PathSeparator
strStation = ThisWorkbook.Worksheets("Rechner2").Cells(20, 4).Value
' Prüfen...
If Len(strStation) < 1 Then
lngError = 1
Else
' Ordner abfragen...
strDownload = GetFolder(cstFolderDefault, False)
strArchive = strDownload & strSeparator & cstFolderArchive
' Existenz prüfen...
If Len(Dir(strDownload, vbDirectory)) > 0 Then
' Existenz vom Archivordner prüfen...
If Len(Dir(strArchive, vbDirectory)) < 1 Then
' Erstellen...
MkDir strArchive
' Prüfen...
If Len(Dir(strArchive, vbDirectory)) < 1 Then
lngError = 3
End If
End If
Else
lngError = 2
End If
End If
' Fehlerprüfung...
If lngError < 1 Then
' Parameter...
strFile = "MOSMIX_L_LATEST_" & strDate & "_" & strStation & "_" & strTime & ".zip"
strUrl = "https://opendata.dwd.de/weather/local_forecasts/mos/MOSMIX_L/single_stations/" & _
strStation & "/kml/" & "MOSMIX_L_LATEST_" & strStation & ".kmz"
' Download...
lngResult = 0
lngResult = URLDownloadToFile(0, strUrl, strDownload & strSeparator & strFile, 0, 0)
' Prüfen...
If lngResult <> 0 Then
lngError = 4
Else
' Existenz...
If UCase(Dir(strDownload & strSeparator & strFile)) <> _
UCase(strFile) Then
lngError = 4
End If
End If
End If
' Fehlerprüfung...
If lngError < 1 Then
' Kopieren...
FileCopy strDownload & strSeparator & strFile, _
strArchive & strSeparator & strFile
' Existenz...
If UCase(Dir(strArchive & strSeparator & strFile)) <> _
UCase(strFile) Then
lngError = 5
Else
' Löschen...
Kill strDownload & strSeparator & strFile
End If
End If
' Fehlerprüfung...
If lngError < 1 Then
' Entpacken...
strFileKML = ""
strFileKML = Unzip(strArchive & strSeparator & strFile)
' Prüfen...
If Len(strFileKML) > 0 Then
' Archiv löschen...
Kill strArchive & strSeparator & strFile
' Textdatei...
strFileText = Replace(strFileKML, ".kml", ".txt")
' Existenz...
If Not UCase(Dir(strArchive & strSeparator & strFileText)) <> _
UCase(strFileText) Then
Kill strArchive & strSeparator & strFileText
End If
' Umbenennen...
Name strArchive & strSeparator & strFileKML As _
strArchive & strSeparator & strFileText
Else
lngError = 6
End If
End If
' Fehlerprüfung...
If lngError < 1 Then
' Importieren...
Application.Workbooks.OpenText _
Filename:=strArchive & strSeparator & strFileText, _
Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, _
Tab:=True, Semicolon:=False, Comma:=False, Space:=True, _
Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), _
Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1)), _
TrailingMinusNumbers:=True
' Kopieren...
'
' Ggf. ThisWorkbook durch Application.Workbooks("NAME") ersetzen
Application.Workbooks(Application.Workbooks.Count).Worksheets(1).Copy _
After:=ThisWorkbook.Worksheets(9)
' Schließen...
Application.Workbooks(Application.Workbooks.Count).Close False
End If
' Fehlermeldungen...
If lngError > 0 Then
Select Case lngError
Case 1
MsgBox "Keine Station angegeben.", vbExclamation + vbOKOnly
Case 2
MsgBox "Zielordner nicht gefunden.", vbExclamation + vbOKOnly
Case 3
MsgBox "Archivordner konnte nicht erstellt werden.", vbExclamation + vbOKOnly
Case 4
MsgBox "Download ist fehlgeschlagen.", vbExclamation + vbOKOnly
Case 5
MsgBox "Downloaddatei kann nicht in den Archivordner kopiert werden.", vbExclamation + vbOKOnly
Case 6
MsgBox "Das Archiv konnte nicht entpackt werden.", vbExclamation + vbOKOnly
Case Else
End Select
End If
End SubGruß
RE: Umbenennen einer Datei - Niko - 24.11.2019
Hallo maninweb, ich bin gerade etwas sprachlos. Echt super, dass du dir die Mühe gemacht hast und mir den Code quasi neugeschrieben hast. Ich habe den Code ausprobiert und es scheint alles einwandfrei zu funktionieren. Ich habe nun jedoch das Problem, dass ich wirklich Schwierigkeiten habe deinen Code zu verstehen. Ich bin kein gelernter Programmierer und Google mir oft Funktionen zusammen, die ich dann bei mir anwende. Mir war auch bewusst, dass mein eigener Code nicht der Beste war und, dass es elegantere Lösungen gibt. Aber im Prinzip hat er bis auf den oben beschriebenen Fehler alles getan, was ich wollte. Das ganze erschwert es mir jetzt weiter mit dem Code zu arbeiten und veränderungen vorzunehmen.
Ich bin gerade auch etwas ratlos was ich tun soll. Mir fallen etliche Fragen zum Code ein. Ist nur die Frage, ob du dir die Mühe machen würdest alle zu beantworten.
Eine Frage vorab. Wie wird denn die Datei entpackt. Bei mir hatte ich ja die Winrar.exe aufgerufen aber in deinem Code erkenne ich nichts dergleichen.
Grüße Niko
RE: Umbenennen einer Datei - maninweb - 24.11.2019
Hallo,
Du kannst gerne so viele Fragen stellen, wie Du möchtest. Ich kann nur nicht garantieren, sofort darauf zu antworten.
Kann also sein, dass es durchaus mal 1-2 Tage dauert.
Das Entpacken geschieht per Windows Shell (also Explorer) in der Prozedur Unzip.
Gruß
RE: Umbenennen einer Datei - Niko - 10.12.2019
Hallo Maninweb, Ich habe ein paar Dinge an dem Code verändert und hab natürlich jetzt wieder einen Fehler den ich selber nicht beheben kann bzw. mir ihn nicht erklren kann. Vielleicht kannst du mir wieder mal helfen.
Der Code sieht folgendermaßen aus, man muss dazu sagen, dass er noch nicht fertig ist. Die Zeile "strFileText = replace(strFileKML, ".kml", "_" & strTime & ".txt")" macht jetzt aber Probleme und sagt, dass ich einen Laufzeitfehler 13 habe und die Typen unverträglich sind.
Danke im Voraus!
Dim intZeileStart As Integer 'Beginn der Prognosetemperatur
Dim strBlattname As String
Dim Sheet As Worksheet
Dim find As Variant
Dim replace As Variant
Dim Kelvin As Double
Dim intSpalteStart As Integer
Dim intInhaltZelle As String
Dim intDatumPrognose As Integer
Dim DatumAktuell As Date
Dim strDate As String
Dim strTime As String
Dim lngError As Long
Dim lngResult As Long
Dim strArchive As String
Dim strDownload As String
Dim strFile As String
Dim strFileKML As String
Dim strFileText As String
Dim strSeparator As String
Dim strStation As String
Dim strUrl As String
Option Explicit
' API...
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
' Konstanten...
Private Const cstFolderArchive As String = "Archiv"
Private Const cstFolderDefault As String = "C:\"
' Private...
Private Function GetFolder(Default As String, Override As Boolean) As String
Dim r As String
' Übergehen...
If Not Override Then
' Dialog aufrufen...
With Application.FileDialog(msoFileDialogFolderPicker)
' Einstellungen..
.AllowMultiSelect = False
.Title = "Bitte Ordner wählen"
.InitialFileName = cstFolderDefault
.InitialView = msoFileDialogViewThumbnail
.ButtonName = "OK"
' Anzeigen...
If .Show = -1 Then
r = .SelectedItems(1)
End If
End With
End If
' Standardordner falls abgebrochen oder übergangen...
If Len® < 1 Then
r = Default
End If
' Return...
GetFolder = r
End Function
Public Function Unzip(Source As Variant) As String
Dim objShell As Object
Dim objSource As Object
Dim objTarget As Object
Dim objItem As Object
Dim strResult As String
Dim strSeparator As String
Dim vntFolder As Variant
' Fehler...
On Error Resume Next
' Initialisieren...
strResult = ""
strSeparator = Application.PathSeparator
vntFolder = Left(Source, Len(Source) - Len(Split( _
StrReverse(Source), strSeparator)(0)))
' Shell..
Set objShell = CreateObject("Shell.Application")
' Prüfen...
If Not objShell Is Nothing Then
' Namespaces...
Set objSource = objShell.Namespace(Source)
Set objTarget = objShell.Namespace(vntFolder)
' Prüfen...
If Not objSource Is Nothing And _
Not objTarget Is Nothing Then
' Anzahl...
If objSource.Items.Count > 0 Then
' Erstes Element...
strResult = objSource.Items.Item(0).Name
' Löschen...
If Not UCase(Dir(vntFolder & strSeparator & strResult)) <> _
UCase(strResult) Then
Kill vntFolder & strSeparator & strResult
End If
' Nicht vorhanden oder erfolgreich gelöscht...
If UCase(Dir(vntFolder & strSeparator & strResult)) <> _
UCase(strResult) Then
objTarget.CopyHere objSource.Items.Item(0)
End If
End If
End If
End If
' Aufräumen...
Set objTarget = Nothing
Set objSource = Nothing
Set objShell = Nothing
' Ergebnis...
Unzip = strResult
End Function
' Public...
Public Sub Prognose()
' Initialisieren...
lngError = 0
strDate = Format(Date, "YYYYMMDD")
strTime = Format(Time, "hhmmss")
strSeparator = Application.PathSeparator
strStation = ThisWorkbook.Worksheets("Rechner").Cells(4, 1).Value
' Prüfen...
If Len(strStation) < 1 Then
lngError = 1
Else
' Ordner abfragen...
If Sheets("Rechner").Cells(6, 1) = "" Then
strDownload = GetFolder(cstFolderDefault, False)
Sheets("Rechner").Cells(6, 1) = strDownload
Else
strDownload = Sheets("Rechner").Cells(6, 1)
End If
strArchive = strDownload & strSeparator & cstFolderArchive
' Existenz prüfen...
If Len(Dir(strDownload, vbDirectory)) > 0 Then
' Existenz vom Archivordner prüfen...
If Len(Dir(strArchive, vbDirectory)) < 1 Then
' Erstellen...
MkDir strArchive
' Prüfen...
If Len(Dir(strArchive, vbDirectory)) < 1 Then
lngError = 3
End If
End If
Else
lngError = 2
End If
End If
' Fehlerprüfung...
If lngError < 1 Then
' Parameter...
strFile = "MOSMIX_L_LATEST_" & strDate & "_" & strStation & "_" & strTime & ".zip"
strUrl = "https://opendata.dwd.de/weather/local_forecasts/mos/MOSMIX_L/single_stations/" & _
strStation & "/kml/" & "MOSMIX_L_LATEST_" & strStation & ".kmz"
' Download...
lngResult = 0
lngResult = URLDownloadToFile(0, strUrl, strDownload & strSeparator & strFile, 0, 0)
' Prüfen...
If lngResult <> 0 Then
lngError = 4
Else
' Existenz...
If UCase(Dir(strDownload & strSeparator & strFile)) <> _
UCase(strFile) Then
lngError = 4
End If
End If
End If
' Fehlerprüfung...
If lngError < 1 Then
' Kopieren...
FileCopy strDownload & strSeparator & strFile, _
strArchive & strSeparator & strFile
' Existenz...
If UCase(Dir(strArchive & strSeparator & strFile)) <> _
UCase(strFile) Then
lngError = 5
Else
' Löschen...
Kill strDownload & strSeparator & strFile
End If
End If
' Fehlerprüfung...
If lngError < 1 Then
' Entpacken...
strFileKML = ""
strFileKML = Unzip(strArchive & strSeparator & strFile)
' Prüfen...
If Len(strFileKML) > 0 Then
' Archiv löschen...
Kill strArchive & strSeparator & strFile
' Textdatei...
strFileText = replace(strFileKML, ".kml", "_" & strTime & ".txt")
' Existenz...
If Not UCase(Dir(strArchive & strSeparator & strFileText)) <> _
UCase(strFileText) Then
Kill strArchive & strSeparator & strFileText
End If
' Umbenennen...
Name strArchive & strSeparator & strFileKML As _
strArchive & strSeparator & strFileText
Else
lngError = 6
End If
End If
' Fehlerprüfung...
If lngError < 1 Then
' Importieren...
Application.Workbooks.OpenText _
Filename:=strArchive & strSeparator & strFileText, _
Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, _
Tab:=True, Semicolon:=False, Comma:=False, Space:=True, _
Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), _
Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1)), DecimalSeparator:="." _
, ThousandsSeparator:=",", TrailingMinusNumbers:=True
' Kopieren...
'
' Ggf. ThisWorkbook durch Application.Workbooks("NAME") ersetzen
Application.Workbooks(Application.Workbooks.Count).Worksheets(1).Copy _
After:=ThisWorkbook.Worksheets(2)
' Schließen...
Application.Workbooks(Application.Workbooks.Count).Close False
End If
' Fehlermeldungen...
If lngError > 0 Then
Select Case lngError
Case 1
MsgBox "Keine Station angegeben.", vbExclamation + vbOKOnly
Case 2
MsgBox "Zielordner nicht gefunden.", vbExclamation + vbOKOnly
Case 3
MsgBox "Archivordner konnte nicht erstellt werden.", vbExclamation + vbOKOnly
Case 4
MsgBox "Download ist fehlgeschlagen.", vbExclamation + vbOKOnly
Case 5
MsgBox "Downloaddatei kann nicht in den Archivordner kopiert werden.", vbExclamation + vbOKOnly
Case 6
MsgBox "Das Archiv konnte nicht entpackt werden.", vbExclamation + vbOKOnly
Case Else
End Select
End If
End Sub
Public Sub Ordnerwahl()
Sheets("Rechner").Cells(6, 1) = GetFolder(cstFolderDefault, False)
End Sub
Public Sub Prognosedaten()
Kelvin = 273.15
strDate = Format(Date, "YYYYMMDD")
strTime = Format(Time, "hhmmss")
SheetName = "Prog_" & strDate & "_" & strTime
'Suche nach "TTT"_________________________________________________________
Cells.find(What:="""TTT""", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
intZeileStart = ActiveCell.Row
intSpalteStart = ActiveCell.Column
'Cells.replace What:=".", Replacement:=",", LookAt:=xlPart, SearchOrder _
':=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
With ThisWorkbook
.Sheets.Add After:=Sheets(Worksheets.Count)
.ActiveSheet.Name = SheetName
End With
Sheets(SheetName).Cells(1, 1) = "Datum_Uhrzeit"
Sheets(SheetName).Cells(1, 2) = "Temp_i"
Sheets(SheetName).Cells(1, 3) = "Datum"
Sheets(SheetName).Cells(1, 4) = "Temp_d"
i = 0
Do
Sheets(SheetName).Cells(i + 2, 2) = Sheets(strBlattname).Cells(intZeileStart + 1, intSpalteStart + i) - Kelvin
i = i + 1
Loop Until IsNumeric(Sheets(strBlattname).Cells(intZeileStart + 1, intSpalteStart + i)) = False
'Suche nach timestep
Worksheets(strBlattname).Select
Cells.find(What:="timestep", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
Cells.FindNext(After:=ActiveCell).Activate
intInhaltZelle = ActiveCell
strDatumPrognose = GetNumeric(intInhaltZelle)
testDate = CDate(strDatumPrognose)
Sheets(SheetName).Cells(2, 1) = testDate
For j = 0 To i - 2
Sheets(SheetName).Cells(j + 3, 1) = Sheets(SheetName).Cells(j + 2, 1) + 1 / 24
Next j
Worksheets(SheetName).Select
Columns("A:A").Select
Selection.NumberFormat = "m/d/yyyy h:mm"
i = 1
Laufvariable1 = 0
Worksheets(SheetName).Activate
Zeile1 = 2
Do Until Range("B1").Offset(i, 0) = ""
TagZahl = TagZahl + 1
Laufvariable1 = Laufvariable1 + 1
If Laufvariable1 = 1 Then
Laufvariable2 = Sheets(SheetName).Cells(i + 1, 2)
Else
Laufvariable2 = Laufvariable2 + Sheets(SheetName).Cells(i + 1, 2)
End If
If Laufvariable1 = 24 Then
Sheets(SheetName).Cells(Zeile1, 4) = Laufvariable2 / 24
Zeile1 = Zeile1 + 1
Laufvariable1 = 0
End If
i = i + 1
Loop
TagZahl = (TagZahl / 24)
End Sub
RE: Umbenennen einer Datei - maninweb - 11.12.2019
Hallo,
auf den ersten Blick, Du hast eine Variable Replace deklariert. Das beisst sich mit der VBA-Funktion Replace.
Variablennamen sollten nicht den Namen von VBA-Funktionen bzw. Methoden tragen (Daher z.B. oft Prefixe).
Ersetze mal Deine Variable Replace durch einen anderen Namen.
Gruß
RE: Umbenennen einer Datei - Niko - 13.12.2019
Hat funktioniert, Danke!