|
Hallo zusammen!
Ich habe ein kleines VBA-Problem und hoffe ihr könnt mir weiterhelfen!
Ich habe mir ein Excel Sheet erstellt. In den Zellen E10 und E11 kann ich zwei Datümer einsetzen und mit den Button wird über ein VBA-Code eine Datenbank zu den beiden Stichtagen abgefragt und in das Excel-Sheet kopiert.
Soweit klappt das auch alles sehr gut.
Nun möchte ich in Zelle E15 als weitere Abfragevariable die Währung definieren. Und hier scheitere ich weil die Währung ja kein Date ist. Ich weiß nicht wie ich den vorhanden Code ergänzen muss damit ich auch die Variable Währung einbeziehen kann. Vielleicht könnt ihr mir hier weiterhelfen??
DANKE
[code][/Private Sub CommandButton1_Click()
' Variablen definieren
Dim sSheetSQLRohdaten1 As String ' Blatt, in das die Datenbankabfrage im Rohformat geschrieben wird
Dim sSQLConnection As String ' Datenbankverbindung
Dim sSQLDatabase As String ' die ODBC-Verknüpfung
Dim sSQLStatement As String ' das SQL-Statement
Dim i As Integer
Dim iReportday_Start As Date ' Stichtagsdatum für die Queries (Report_Day)
Dim iReportday_End As Date ' Stichtagsdatum für die Queries (Compare_Day)
Dim oldScreenUpdating, oldDisplayStatusBar, oldEnableEvents As Boolean
Dim oldCalculation As Long
' Excel-Einstellungen sichern und Performancefresser ausschalten
On Error GoTo Fehler:
With Application
oldScreenUpdating = .ScreenUpdating
oldCalculation = .Calculation
oldDisplayStatusBar = .DisplayStatusBar
oldEnableEvents = .EnableEvents
oldDecimalSeparator = .DecimalSeparator
oldThousandsSeparator = .ThousandsSeparator
oldUseSystemSeparators = .UseSystemSeparators
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayStatusBar = False
.Application.EnableEvents = False
.DecimalSeparator = ","
.ThousandsSeparator = "."
.UseSystemSeparators = True
End With
' Variablen definieren
sSheetMenu = "Menu"
sSheetSQLRohdaten1 = "Quelle"
sSQLDatabase = "xxxxxx\xxxx"
sSQLConnection = "ODBC;Driver={SQL Server};Server=xxxxxxxx;Trusted_Connection=Yes;APP=Microsoft Office 2010"
iReportday_Start = CDate(Worksheets(sSheetMenu).Range("ReportDay_Start").Value)
iReportday_End = CDate(Worksheets(sSheetMenu).Range("ReportDay_End").Value)
'Import Quelledaten
' das Blatt bereinigen, bevor neue Daten eingetragen werden
With Worksheets(sSheetSQLRohdaten1)
.Range(.Cells(Worksheets(sSheetSQLRohdaten1).Range("REPORT_DATE").Row, 1), .Cells(65536, 42)).ClearContents
End With
' die Datenbank abfragen
With Worksheets(sSheetSQLRohdaten1).QueryTables.Add(Connection:=sSQLConnection, Destination:=Sheets(sSheetSQLRohdaten1).Range("REPORT_DATE"))
.RefreshStyle = xlOverwriteCells
sSQLStatement = GetSQLFromFile("N:\xxx\xxxx\xxx\xxx\xxxxxx.sql")
sSQLStatement = ReplaceStichtag(sSQLStatement, "#REPORTDAY_Start#", iReportday_Start)
.CommandText = CleanSQLCode(sSQLStatement)
Debug.Print "sSQLStatement= " + .CommandText
.Refresh BackgroundQuery:=False
End With
' Jetzt noch ein paar Formatbereinigungen durchführen
With Worksheets(sSheetSQLRohdaten1)
i = Worksheets(sSheetSQLRohdaten1).Range("REPORT_DATE").Row
While Not IsEmpty(.Cells(i, 1).Value)
If InStr(.Cells(i, 1).Value, "-") <> 0 Then
sDate = CStr(.Cells(i, 1).Value)
iDate = CDate(Right(sDate, 2) & "." & Mid(sDate, 6, 2) & "." & Left(sDate, 4))
.Cells(i, 1).Value = iDate
End If
i = i + 1
Wend
End With
' Die Namensliste aufräumen
Call DeleteNamesExtData
Fehler:
If Err.Number <> 0 Then
Mldg = "Fehler # " & Str(Err.Number) & " wurde ausgelöst von " _
& Err.Source & Chr(13) & Err.Description
MsgBox Mldg, , "Fehler", Err.HelpFile, Err.HelpContext
End If
' und am Ende den Ursprungszustand wieder herstellen
With Application
.ScreenUpdating = oldScreenUpdating
.Calculation = oldCalculation
.Calculate
.DisplayStatusBar = True 'oldDisplayStatusBar --> die immer anzeigen
.Application.EnableEvents = oldEnableEvents
.DecimalSeparator = oldDecimalSeparator
.ThousandsSeparator = oldThousandsSeparator
.UseSystemSeparators = oldUseSystemSeparators
Worksheets(sSheetMenu).Activate
End With
End Sub
Function GetSQLFromFile(sFileDir As String) As String
Dim Datei ' Objekt für den Dateiinhalt
Dim FSO ' Objekt zum Einlesen von Textdateien
Dim sFileString As String
Set FSO = CreateObject("Scripting.FilesystemObject")
Set Datei = FSO.OpentextFile(sFileDir)
sFileString = Datei.readall
Datei.Close
GetSQLFromFile = sFileString
End Function
Function CleanSQLCode(sSQLCode As String) As String
Dim sSQLAll As String
Dim sSQLRow() As String
Dim sRow As Variant
Dim sFinalSQLString As String
Dim iCutPoint As Integer
sSQLRow() = Split(sSQLCode, vbCrLf) ' Trennt den gesamten String in Zeilen
sFinalSQLString = ""
' Zeilenweise den String auslesen und sobald in einer Zeile zwei aufeinanderfolgene Minuszeichen erscheinen, wird die Zeile abgeschnitten
' Tabs können auch eliminiert werden, da diese für das Statement nicht notwendig sind
For Each sRow In sSQLRow
If (sRow <> "") And Not (IsEmpty(sRow)) Then
iCutPoint = InStr(sRow, "--")
If (iCutPoint) Then
'sFinalSQLString = sFinalSQLString + Left(sRow, iCutPoint - 1) + vbCrLf
Else
sFinalSQLString = sFinalSQLString + sRow + vbCrLf
End If
End If
Next
sFinalSQLString = Replace(sFinalSQLString, vbCrLf, " ") ' Alle Zeilenumbrüche durch Leerzeichen ersetzen
sFinalSQLString = Replace(sFinalSQLString, vbTab, " ") ' Alle Tabulatorzeichen durch Leerzeichen ersetzen
sFinalSQLString = Replace(sFinalSQLString, " ,", ",") ' Alle Leerzeichen vor Kommatas entfernen
sFinalSQLString = Replace(sFinalSQLString, " =", "=") ' Alle Leerzeichen vor Gleichheitszeichen entfernen
sFinalSQLString = Replace(sFinalSQLString, "= ", "=") ' Alle Leerzeichen nach Gleichheitszeichen entfernen
sFinalSQLString = Replace(sFinalSQLString, " >", ">") ' Alle Leerzeichen vor Größerzeichen entfernen
sFinalSQLString = Replace(sFinalSQLString, "> ", ">") ' Alle Leerzeichen nach Größerzeichen entfernen
sFinalSQLString = Replace(sFinalSQLString, " <", "<") ' Alle Leerzeichen vor Kleinerzeichen entfernen
sFinalSQLString = Replace(sFinalSQLString, "< ", "<") ' Alle Leerzeichen nach Kleinerzeichen entfernen
While InStr(sFinalSQLString, " ") > 0
sFinalSQLString = Replace(sFinalSQLString, " ", " ") ' Alle doppelten durch einfache Leerzeichen ersetzen
Wend
CleanSQLCode = sFinalSQLString
End Function
Function ReplaceStichtag(sSQLStatement As String, sReplaceString As String, iReportday As Date) As String
ReplaceStichtag = Replace(sSQLStatement, sReplaceString, Year(iReportday) & "-" & Format(Month(iReportday), "0#") & "-" & Day(iReportday))
End Function
Sub DeleteNamesExtData()
Dim srcName As Name
For Each srcName In ThisWorkbook.Names
If Left(srcName.Name, 13) = "ExterneDaten_" Then 'Tabellennamen anpassen und Zahl 21 je nach Namenslänge ändern
srcName.Delete
End If
Next
End Sub
Private Sub Label2_Click()
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub
code] |