<pre>
Public Function PT_GetRecordset(ByVal sqlSelect As String, _
ByVal sqlFrom As String, _
ByVal sqlWhere As String, _
Optional ByRef NumRows As Long, _
Optional ByRef NumFields As Long)
Dim CriteraAND, splTMP, ErgebnisZeile(), sSelect As Variant
Dim CritField(), CritVal() As String
Dim i, AngezeigteSpalten, ErsteSichtbareZeile, intCT, intCT2, Abzug As Integer
Dim r As Range
On Error GoTo fehler
PT_GetRecordset = ErgebnisZeile
If GetSpalten = "@" Then MsgBox "Erste Zelle der Tabelle '" & sqlFrom & _
"' ist leer!", vbInformation, _
"PT_GetRecordSet": Exit Function
sSelect = Split(sqlSelect, ",")
Sheets(sqlFrom).Select
CriteraAND = Split(UCase(sqlWhere), "AND")
Range("A:" & GetSpalten).Select
Selection.AutoFilter
If LCase(sqlWhere) <> "true" Then
For i = 0 To UBound(CriteraAND)
splTMP = Split(CriteraAND(i), "=")
ReDim Preserve CritField(i)
ReDim Preserve CritVal(i)
CritField(i) = Trim$(splTMP(0))
CritVal(i) = Trim$(splTMP(1))
Next
Selection.AutoFilter Field:=GetColumnIndex(CritField(0), Range("1:1")), _
Criteria1:="=" & CritVal(0), Operator:=xlAnd
For i = 0 To UBound(CritField)
If CritField(i) <> "" Then Selection.AutoFilter Field:=GetColumnIndex(CritField(i), _
Range("1:1")), Criteria1:="=" & CritVal(i), _
Operator:=xlAnd Else Exit For
Next
Else
Selection.AutoFilter
End If
For Each r In Range("A:A")
If r.RowHeight <> 0 And r.Row <> 1 Then Exit For
Next
ErsteSichtbareZeile = r.Row
For Each r In Range("A:A")
If r = "" And r.Row >= ErsteSichtbareZeile Then Exit For
If r.RowHeight > 0 And r.Row >= ErsteSichtbareZeile Then Abzug = Abzug + 1
Next
NumRows = r.Row - ErsteSichtbareZeile - Abzug - 1
If sqlSelect <> "*" Then
If LCase(sqlWhere) <> "true" Then ReDim ErgebnisZeile(NumRows, UBound(sSelect)) Else _
ReDim ErgebnisZeile(r.Row, UBound(sSelect))
Else
If LCase(sqlWhere) <> "true" Then ReDim ErgebnisZeile(NumRows, GetSpaltenIndex) Else _
ReDim ErgebnisZeile(r.Row, UBound(sSelect))
End If
intCT = 1
For Each r In Range("A:A")
If r = "" And r.Row >= ErsteSichtbareZeile Then Exit For
If r.RowHeight > 0 And r.Row >= ErsteSichtbareZeile Then
intCT2 = 0
For i = 1 To GetSpaltenIndex
If InStr(1, sqlSelect, Range(Chr$(64 + i) & "1")) Or sqlSelect = "*" Then
ErgebnisZeile(intCT - 1, intCT2) = Range(Chr$(64 + i) & r.Row)
intCT2 = intCT2 + 1
End If
Next
intCT = intCT + 1
End If
Next
NumFields = intCT2
PT_GetRecordset = ErgebnisZeile
Exit Function
fehler:
MsgBox "Fehler:" & vbCrLf & _
vbCrLf & _
"sqlSelect = " & sqlSelect & vbCrLf & _
"sqlFrom = " & sqlFrom & vbCrLf & _
"sqlWhere = " & sqlWhere, _
vbInformation, "PT_GetRecordset"
End Function
Function GetColumnIndex(varSearch As Variant, rng As Range) As Integer
Dim var As Variant
Dim iCol As Integer
For iCol = 1 To rng.Columns.Count
var = Application.Match(varSearch, rng.Columns(iCol), 0)
If Not IsError(var) Then
GetColumnIndex = iCol
Exit Function
End If
Next iCol
End Function
Function GetSpalten() As String
Dim r As Range
Dim intCount As Integer
For Each r In Range("1:1")
If Trim$(r) <> "" Then intCount = intCount + 1 Else Exit For
Next
GetSpalten = Chr$(64 + intCount)
End Function
Function GetSpaltenIndex() As Integer
Dim r As Range
Dim intCount As Integer
For Each r In Range("1:1")
If Trim$(r) <> "" Then intCount = intCount + 1 Else Exit For
Next
GetSpaltenIndex = intCount
End Function
'[in] sqlSelect Kommagetrennter String mit Rückgabe Feldern ("Feld1, Feld2")
'[in] sqlFrom Name der Tabelle ("Tabelle1")
'[in] sqlWhere Auswahlkriterien ("Feld3=4 AND Feld4=5")
'[out] NumRows Anzahl der gefundenen Zeilen (3)
'[out] NumFields Anzahl der Rückgabe Spalten (2)
'
'Die Funktion liefert dann ein doppeltes Array mit den Werten,
'oder Empty wenn keine Übereinstimmung.
'z.b. Rückgabe(0)(0) = 1, Rückgabe(0)(1) = 2 ...
'
'Besonderheiten:
'sqlSelect = "*" -> Alle Spalten
'sqlWhere = "True" -> Keine Bedingungen
</pre>
Aufgerufen wir das ganze etwa so:
<pre>Sub Schaltfläche1_BeiKlick()
Dim RV As Variant
RV = PT_GetRecordset("Name,Strasse", "Tabelle1", "Wohnort=Stuttgart AND Hausnummer=65")
MsgBox RV(0, 0)
End Sub
</pre>
hab ich auf der arbeit zusammenstellen müssen (für eine konvertierung einer access-anwendung nach excel).. 8)
p.s. wie macht man hier im forum, dass mehrere leerzeichen hintereinander angezeigt werden? ich hätt's mit "& nbsp;" gemacht, da wird die nachricht aber zu lang![;)](https://www.vb-paradise.de/wcf/images/smilies/wink.png)
//edit: dank markus seinem tipp "CODE.." ist das problem gelöst
Public Function PT_GetRecordset(ByVal sqlSelect As String, _
ByVal sqlFrom As String, _
ByVal sqlWhere As String, _
Optional ByRef NumRows As Long, _
Optional ByRef NumFields As Long)
Dim CriteraAND, splTMP, ErgebnisZeile(), sSelect As Variant
Dim CritField(), CritVal() As String
Dim i, AngezeigteSpalten, ErsteSichtbareZeile, intCT, intCT2, Abzug As Integer
Dim r As Range
On Error GoTo fehler
PT_GetRecordset = ErgebnisZeile
If GetSpalten = "@" Then MsgBox "Erste Zelle der Tabelle '" & sqlFrom & _
"' ist leer!", vbInformation, _
"PT_GetRecordSet": Exit Function
sSelect = Split(sqlSelect, ",")
Sheets(sqlFrom).Select
CriteraAND = Split(UCase(sqlWhere), "AND")
Range("A:" & GetSpalten).Select
Selection.AutoFilter
If LCase(sqlWhere) <> "true" Then
For i = 0 To UBound(CriteraAND)
splTMP = Split(CriteraAND(i), "=")
ReDim Preserve CritField(i)
ReDim Preserve CritVal(i)
CritField(i) = Trim$(splTMP(0))
CritVal(i) = Trim$(splTMP(1))
Next
Selection.AutoFilter Field:=GetColumnIndex(CritField(0), Range("1:1")), _
Criteria1:="=" & CritVal(0), Operator:=xlAnd
For i = 0 To UBound(CritField)
If CritField(i) <> "" Then Selection.AutoFilter Field:=GetColumnIndex(CritField(i), _
Range("1:1")), Criteria1:="=" & CritVal(i), _
Operator:=xlAnd Else Exit For
Next
Else
Selection.AutoFilter
End If
For Each r In Range("A:A")
If r.RowHeight <> 0 And r.Row <> 1 Then Exit For
Next
ErsteSichtbareZeile = r.Row
For Each r In Range("A:A")
If r = "" And r.Row >= ErsteSichtbareZeile Then Exit For
If r.RowHeight > 0 And r.Row >= ErsteSichtbareZeile Then Abzug = Abzug + 1
Next
NumRows = r.Row - ErsteSichtbareZeile - Abzug - 1
If sqlSelect <> "*" Then
If LCase(sqlWhere) <> "true" Then ReDim ErgebnisZeile(NumRows, UBound(sSelect)) Else _
ReDim ErgebnisZeile(r.Row, UBound(sSelect))
Else
If LCase(sqlWhere) <> "true" Then ReDim ErgebnisZeile(NumRows, GetSpaltenIndex) Else _
ReDim ErgebnisZeile(r.Row, UBound(sSelect))
End If
intCT = 1
For Each r In Range("A:A")
If r = "" And r.Row >= ErsteSichtbareZeile Then Exit For
If r.RowHeight > 0 And r.Row >= ErsteSichtbareZeile Then
intCT2 = 0
For i = 1 To GetSpaltenIndex
If InStr(1, sqlSelect, Range(Chr$(64 + i) & "1")) Or sqlSelect = "*" Then
ErgebnisZeile(intCT - 1, intCT2) = Range(Chr$(64 + i) & r.Row)
intCT2 = intCT2 + 1
End If
Next
intCT = intCT + 1
End If
Next
NumFields = intCT2
PT_GetRecordset = ErgebnisZeile
Exit Function
fehler:
MsgBox "Fehler:" & vbCrLf & _
vbCrLf & _
"sqlSelect = " & sqlSelect & vbCrLf & _
"sqlFrom = " & sqlFrom & vbCrLf & _
"sqlWhere = " & sqlWhere, _
vbInformation, "PT_GetRecordset"
End Function
Function GetColumnIndex(varSearch As Variant, rng As Range) As Integer
Dim var As Variant
Dim iCol As Integer
For iCol = 1 To rng.Columns.Count
var = Application.Match(varSearch, rng.Columns(iCol), 0)
If Not IsError(var) Then
GetColumnIndex = iCol
Exit Function
End If
Next iCol
End Function
Function GetSpalten() As String
Dim r As Range
Dim intCount As Integer
For Each r In Range("1:1")
If Trim$(r) <> "" Then intCount = intCount + 1 Else Exit For
Next
GetSpalten = Chr$(64 + intCount)
End Function
Function GetSpaltenIndex() As Integer
Dim r As Range
Dim intCount As Integer
For Each r In Range("1:1")
If Trim$(r) <> "" Then intCount = intCount + 1 Else Exit For
Next
GetSpaltenIndex = intCount
End Function
'[in] sqlSelect Kommagetrennter String mit Rückgabe Feldern ("Feld1, Feld2")
'[in] sqlFrom Name der Tabelle ("Tabelle1")
'[in] sqlWhere Auswahlkriterien ("Feld3=4 AND Feld4=5")
'[out] NumRows Anzahl der gefundenen Zeilen (3)
'[out] NumFields Anzahl der Rückgabe Spalten (2)
'
'Die Funktion liefert dann ein doppeltes Array mit den Werten,
'oder Empty wenn keine Übereinstimmung.
'z.b. Rückgabe(0)(0) = 1, Rückgabe(0)(1) = 2 ...
'
'Besonderheiten:
'sqlSelect = "*" -> Alle Spalten
'sqlWhere = "True" -> Keine Bedingungen
</pre>
Aufgerufen wir das ganze etwa so:
<pre>Sub Schaltfläche1_BeiKlick()
Dim RV As Variant
RV = PT_GetRecordset("Name,Strasse", "Tabelle1", "Wohnort=Stuttgart AND Hausnummer=65")
MsgBox RV(0, 0)
End Sub
</pre>
hab ich auf der arbeit zusammenstellen müssen (für eine konvertierung einer access-anwendung nach excel).. 8)
p.s. wie macht man hier im forum, dass mehrere leerzeichen hintereinander angezeigt werden? ich hätt's mit "& nbsp;" gemacht, da wird die nachricht aber zu lang
![;)](https://www.vb-paradise.de/wcf/images/smilies/wink.png)
//edit: dank markus seinem tipp "CODE.." ist das problem gelöst
![;)](https://www.vb-paradise.de/wcf/images/smilies/wink.png)
Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „makrele32“ ()