Umbenennen einer Datei

[Niko]

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

[maninweb]

Hallo,

Du könntest versuchen, statt Name eine Kombination von FileCopy und Kill zu nehmen.

Code:

FileCopy Quelldatei, Zieldatei (beides inkl. Pfad)
Kill Quelldatei

Ggf. nach FileCopy die Existenz der kopierten Datei prüfen (mit Dir) und erst dann die Quelldatei löschen.

Gruß

[Niko]

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:mms")  'aktuele Uhrzeit wird in einer Zeit Variable gespeichert
    Zeit2 = 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

[maninweb]

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 Sub

Gruß

[Niko]

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

[maninweb]

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ß

[Niko]

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

[maninweb]

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ß

[Niko]

Hat funktioniert, Danke!