AW: Dynamischer Datenbankabruf
07.02.2014 11:22:42
fcs
Hallo Oliver,
die Einfüge-Zelle anzupassen ist kein Problem
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & strURL, Destination:=Activecell)
Die aktive Zelle sollte aber nioch bzgl. Spalte und Inhalt überprüft werden.
Und man kann ggf. die nächst höhere ID aus der vorherigen Zeile ermitteln.
Gruß
Franz
Sub GetData_from_fseconomy_net()
Dim strTitel As String
Dim strURL As String, strID As String, wks As Worksheet
strTitel = "D A T E N A B F R A G E - www.fseconomy.net"
'aktive Zelle prüfen.
With ActiveCell
If .Column 1 Then 'Spalte A - 1 ggf. anpassen wenn andere Spalte
If MsgBox("Aktive Zelle ist nicht in Spalte A" & vbLf _
& "Trotzdem Import starten?", vbQuestion + vbOKCancel + vbDefaultButton2, _
strTitel) = vbCancel Then Exit Sub
End If
If .Text "" Then 'aktive Zelle ist nicht leer
If MsgBox("Aktive Zelle ist nicht leer" & vbLf _
& "Trotzdem Import starten?", vbQuestion + vbOKCancel + vbDefaultButton2, _
strTitel) = vbCancel Then Exit Sub
End If
End With
'Nächste ID-Nr. aus vorheriger Zeile ermitteln
strID = Format(Val(ActiveCell.Offset(-1, 0).Text) + 1, "0") 'den Spaltenindex im Offset ggf _
anpassen
'Inputbox zur Bestätigung/Änderung/Abbruch anzeigen
strID = InputBox("Bitte die Start-ID für die Datenabfrage eingeben", _
Title:=strTitel, Default:=strID)
If strID = "" Then Exit Sub 'Abbrechen wurde gewählt
strURL = "http://www.fseconomy.net/data?userkey=9FWFFMUIC9&format=xml&" & _
"query=payments&search=id&readaccesskey=9FWFFMUIC9&fromid=" & strID
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & strURL, Destination:=ActiveCell)
.Name = "Import_aus_Netz" & Format(Now, "YYYYMMDDhhmmss")
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
'Abfrage nach dem Import sofort wieder löschen - diese Anweisung ggf. löschen
ActiveWorkbook.Connections(ActiveWorkbook.Connections.Count).Delete
End Sub