AW: abfragen fortlaufend ausführen
16.06.2008 11:25:11
hwe
hallo,
sowas in der art hatte ich mir vorgestellt...nur leider springt er nicht zur nächsten abfrage...
hab wohl grad ein brett vorm kopf und seh den fehler nicht...
sieht ihn jemand da draußen
grüße
[code]
Sub SQL_Schleife()
Dim i%
For i = 1 To 100 ' #### wenn es in A1 beginnt, sonst anpassen
If Cells(i, 1).Value "" Then
Cells(4, 4).Value = Cells(i, 1).Value
DatenAbfragen ' ###### nur den Namen Deines Makros
Else
Exit Sub
End If
Next i
End Sub
Sub DatenAbfragen()
Dim cnt As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim lFields As Long
Dim iCols As Long
Dim Zeile As Long
Dim sqlreq As String
'Sheets("Eingabe").Select
'Range("CarrierID").Select
' SQL-Abfrage in sqlreq zusammenstellen:
' SQL-Abfrage steht in der ersten Spalte im Blatt "SQL" (beliebig viele Zeilen)
' und muss mit einem einzelnen Semikolon enden!
' SQL in Oracle-Syntax
sqlreq = ""
Zeile = 1
Do
sqlreq = sqlreq & Sheets("SQL").Cells(Zeile, 1).Value & " "
Zeile = Zeile + 1
Loop Until Sheets("SQL").Cells(Zeile, 1).Value = ";"
' Verbindung zur Datenbank herstellen
cnt.Open "Provider=**********;Data Source=***********;User Id=********;Password=***********" _
' Open recordset based on Orders table
rst.Open sqlreq, cnt
' Count the number of fields to place in the worksheet
lFields = rst.Fields.Count
' Ausgabe nach Blatt "Daten", zuerst löschen
Sheets("Daten").Select
Range("A6:AR65536").Select
Selection.ClearContents
Range("A1").Select
' zunächst Bezeichnungen der Datenfelder abfragen und eintragen,
' denn CopyFromRecordset übergibt keine Feldbezeichnungen!
For iCols = 0 To lFields - 1
Cells(5, iCols + 1).Value = rst.Fields(iCols).Name
Next
Range(Cells(5, 1), Cells(5, rst.Fields.Count)).Font.Bold = True
' dann Daten abfragen
Range("A6").CopyFromRecordset rst
' alles wieder schließen
rst.Close
cnt.Close
Set rst = Nothing
Set cnt = Nothing
'Formeln in Tabelle ausfüllen
Zeile = 6
Do Until Cells(Zeile, 1) = ""
Zeile = Zeile + 1
Loop
If Zeile > 6 Then
Range("Y1:AR1").Select
Selection.Copy
Range("Y6:AR" & Format(Zeile - 1)).Select
Selection.PasteSpecial Paste:=xlFormulas, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
End If
'Range("A1").Select
'Diagramm anzeigen
'Sheets("maxHöhe").Select
'ExportWorksheetAsPicture
Dim chtPicture As Chart
Dim strSheetName As String
Application.ScreenUpdating = False
Sheets("RelMaxHöhe (2)").Select
strSheetName = ActiveSheet.Name
ActiveSheet.Range("A1:N49").CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set chtPicture = Charts.Add
chtPicture.Paste
chtPicture.Export ActiveWorkbook.Path & "\" & strSheetName & ".gif"
Application.DisplayAlerts = False
chtPicture.Delete
Application.DisplayAlerts = True
Set chtPicture = Nothing
Application.ScreenUpdating = True
End Sub
[/code]