Private Declare 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
Public Function DownloadFile(URL As String, LocalFilename As String) As Boolean
  Dim lngRetVal As Long
  lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
  If lngRetVal = 0 Then DownloadFile = True
End Function

'Sub Auto_open()

'Dim Antwort
'Antwort = MsgBox("Soll die Aktuelle Preisliste heruntergeladen werden?", 4, "Frage")
'    If Antwort = vbYes Then
'       Dim strURL As String, strLokal As String
'  strURL = "https://docs.google.com/spreadsheet/pub?key=0AvqJa4V4oi0YdDJNSUZ2UXQwdjdDN0NsOFhTZlloaEE&gid=2&single=true&output=xls" 'Dateipfad
'  strLokal = "C:\Users\Pockydor\Desktop\Wurzelimperium\Server46.xls" 'Speicherort
'
'   Else
'
'    End If
'
'      If DownloadFile(strURL, strLokal) = True Then
'    MsgBox "Die Aktuelle Preisliste wurde heruntergeladen!"
 
'  End If
'End Sub

Sub Preisliste_laden_manuel()

Dim Antwort
Antwort = MsgBox("Soll die Aktuelle Preisliste heruntergeladen werden?", 4, "Frage")
    If Antwort = vbYes Then
       Dim strURL As String, strLokal As String
  strURL = "https://docs.google.com/spreadsheet/pub?key=0AvqJa4V4oi0YdDJNSUZ2UXQwdjdDN0NsOFhTZlloaEE&gid=2&single=true&output=xls" 'Dateipfad
  strLokal = "C:\Users\Pockydor\Desktop\Wurzelimperium\Server46.xls" 'Speicherort
 
    Else
   
    End If
   
      If DownloadFile(strURL, strLokal) = True Then
    MsgBox "Die Aktuelle Preisliste wurde heruntergeladen!"
 
  End If

End Sub

='C:\Users\Pockydor\Desktop\Wurzelimperium\[Server46.xls]Aktuell'!C3

Sub InternetabfrageServer46()
Application.ScreenUpdating = False
Dim ServerURL, ServerURL2 As String
Dim a, s, nServer, nVar As Integer
Dim oRange As Object
Dim oSheet As Object
'Die Tabelle, wo eingefügt werden soll
oSheet = Tabelle3
'Der Bereich,wo eingefügt werden soll
oRange = oSheet.Range("D3")
'Adressezu Preisliste von Server46
  ServerURL = "https://docs.google.com/spreadsheet/pub?key=0AvqJa4V4oi0YdDJNSUZ2UXQwdjdDN0NsOFhTZlloaEE&gid=2"
 ServerURL2 = "URL;" + ServerURL
'Alle abfragen auf Tabelle3 Löschen
   s = oSheet.QueryTables().Count
    While s > 0
    oSheet.QueryTables(1).Delete
    s = oSheet.QueryTables().Count
    Wend

   
    On Error GoTo Zeile1
'Neue Abfrage einfügen bei: oRange
    With oSheet.QueryTables.Add(Connection:= _
        ServerURL2 _
        , Destination:=oRange)
        .Name = "ServerURL"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = """tblMain""" 'die Haupttabelle von der Seite.
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
        .RefreshOnFileOpen = True
    End With
Application.ScreenUpdating = True
Zeile1:
    MsgBox "Es ist ein Fehler aufgetreten.", 0, "Fehler"
End Sub