SQL in VBA

[klaas01]

Hallo,

Ik zit met het volgende probleem:

ik heb Excel gekoppeld met een database query waarin 2 tabellen staan:
-medewerkers
-functies

Elke medewerker kan meerdere functies hebben, de functiecodes zijn opgeslagen in het veld functiecodes in de medewerkers tabel en kunnen hiermee gekoppeld worden met de tabel functies.

Indien een mederwerker meerdere functiecodes heeft worden deze gescheiden door een komma.

Nu wil ik met VBA per medewerker bepalen welke functies hij heeft en deze wegschrijven in 1 cel.

Heeft iemand een idee hoe dit in Excel VBA moet gebeuren?

Groeten Klaas

 

[Hans123]

Onderstaande code een tijd terug eens ergens gevonden.

Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
                   sourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' Changed on June-11-2006
    Dim rsData As ADODB.Recordset
    Dim szConnect As String
    Dim szSQL As String
    Dim lCount As Long
 
    If Header = False Then
        ' Create the connection string.
        szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                    "Data Source=" & SourceFile & ";" & _
                    "Extended Properties=""Excel 8.0;HDR=No"";"
    Else
        ' Create the connection string.
        szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                    "Data Source=" & SourceFile & ";" & _
                    "Extended Properties=""Excel 8.0;HDR=Yes"";"
    End If
 
    szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & sourceRange$ & "];"
    On Error GoTo SomethingWrong
    Set rsData = New ADODB.Recordset
    rsData.Open szSQL, szConnect, adOpenForwardOnly, _
                adLockReadOnly, adCmdText
 
    ' Check to make sure we received data and copy the data
    If Not rsData.EOF Then
        If Header = False Then
            TargetRange.Cells(1, 1).CopyFromRecordset rsData
        Else
            'Add the header cell in each column if the last argument is True
            If UseHeaderRow Then
                For lCount = 0 To rsData.Fields.Count - 1
                    TargetRange.Cells(1, 1 + lCount).Value = _
                    rsData.Fields(lCount).Name
                Next lCount
                TargetRange.Cells(2, 1).CopyFromRecordset rsData
            Else
                TargetRange.Cells(1, 1).CopyFromRecordset rsData
            End If
        End If
    Else
        MsgBox "No records returned from : " & SourceFile, vbCritical
    End If
 
    ' Clean up our Recordset object.
    rsData.Close
    Set rsData = Nothing
    Exit Sub
SomethingWrong:
    MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
           vbExclamation, "Error"
    On Error GoTo 0
End Sub
 
 
Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

Dit zou met wat aanpassingen moeten kunnen werken.


Zelf gebruik ik onderstaande code

Public dbFileName As String
Public strTabelName As String
Public rs As Recordset
Public db As Database
Public SetupDataBlad As Worksheet
Public MainProgName As String

Sub Open_dBase(dbFileName As String)
Set db = OpenDatabase(dbFileName, _
        dbDriverNoPrompt, True, _
        "ODBC;DATABASE=X50;UID=Bis;WWD=;DSN=;pwd=wachtwoord")
End Sub

Sub Close_dBase(dbFileName As String)
db.Close
End Sub

Function Select_records(CRIT_SQL$) As Boolean
  Set rs = db.OpenRecordset(CRIT_SQL$)
  If rs.EOF Then                'no recs gevonden
       Select_records = False
    Else                          'wel records gevonden
     Select_records = True      'De reccord set bestaat en heet rs
    rs.MoveLast
    rs.MoveFirst
    End If
End Function
Sub TEST_DB()

            SQL$ = "SELECT * FROM [OPS$DGC2000.MET_POINT]"
            Call ophalen(SQL$)
End Sub


Sub ophalen(SQL$)
       dbFileName = "X50"
        Call Open_dBase(dbFileName)
            bRecsFound = Select_records(SQL$)
            If Not bRecsFound Then
               Beep
               msg = "Niets gevonden dat voldoet........"
                      Style = vbOKOnly + vbExclamation
                      Title = "Geen records gevonden"
                      Antwoord = MsgBox(msg, Style, Title, Help, 64)
               Exit Sub
            End If
            Worksheets("uitvoerblad").Activate
            Select Case meetpunt
                Case Is = 1
                    Worksheets("uitvoerblad").Cells(3, 1).CopyFromRecordset rs
                Case Else
                    Worksheets("uitvoerblad").Cells(3, 1).CopyFromRecordset rs
            End Select
      rs.Close
     Call Close_dBase(dbFileName)
End Sub

De database moet wel bij ODBC koppelingen vermeld zijn.
Hopelijk heb je hier wat aan.