✔ Excel VBA - Vergleiche von Werten unterschiedlicher Tabellen

[Yaslaw]

Ich habe mal eine Gruppierung eingefügt. Wenns mehr als eine Differenz hat, dann wird ein x ausgegeben.

Mein SQL war nur als Beispiel, um zu diesen Lösungsweg zu zeigen. Wenn du es mit SQL umsetzen willst, dann musst du dich damit beschäftigen. Ich werde nicht dein Programm schreiben und warten.

Option Explicit


'http://wiki.yaslaw.info/doku.php/vba/excel/adodbsql

Private Const C_MAIN_SHEET_NAME = "Dauerfahrten"
Private Const C_CHECK_SHEET_NAME = "Check"
Private Const C_DEFAULT_RANGE = "B3:D100"

Private Const C_SQL_MONTH = _
            "select iif(count(*) > 1,'x',max(switch(act.km <> main.km , act.km, not isnull(act.km), 0))) as [{#fld_name}] " & _
            "from [{#tbl_main}] main left join ( " & _
                "select von, nach, km from [{#tbl_act}] where von <> '' " & _
                "union select nach, von, km from [{#tbl_act}] where von <> '' " & _
            ") act " & _
            "on main.von = act.von and main.nach = act.nach " & _
            "where main.von <> '' " & _
            "group by main.von, main.nach " & _
            "order by main.von, main.nach"
           
Private Const C_SQL_BASIC = _
            "SELECT Von, Nach, Km FROM [{#tbl_main}] where von <> '' order by von, nach"

'/**
' * erstellt ein Check-Sheet
' */
Public Sub check()
    Dim ws As Worksheet
    Dim wsCheck As Worksheet
    Dim SQL As String
    Dim colNr As Long
     
    'Checksheet auswählen oder erstellen
On Error Resume Next
    Set wsCheck = ActiveWorkbook.Sheets(C_CHECK_SHEET_NAME)
    If Err.Number <> 0 Then
        Set wsCheck = ActiveWorkbook.Sheets.Add(ActiveWorkbook.Sheets(C_MAIN_SHEET_NAME))
        wsCheck.Name = C_CHECK_SHEET_NAME
    End If
On Error GoTo 0
   
    'Check-Tabelle leeren
    wsCheck.Cells.Clear
   
    'Stammdaten abfüllen
    SQL = Replace(C_SQL_BASIC, "{#tbl_main}", C_MAIN_SHEET_NAME & "$" & C_DEFAULT_RANGE)
    writeFullData wsCheck.Cells(1, 1), openRs(SQL)
   
    colNr = 3
    'Alle Sheets durchgehen
    For Each ws In ActiveWorkbook.Sheets
        'Prüfen, ob es ein Datumssheet ist
        If rxDataSheet.test(ws.Name) Then
            'Spalte eins nach Rechts rücken
            colNr = colNr + 1
           
            'SQL zusammenschustern
            SQL = Replace(C_SQL_MONTH, "{#tbl_main}", C_MAIN_SHEET_NAME & "$" & C_DEFAULT_RANGE)
            SQL = Replace(SQL, "{#tbl_act}", ws.Name & "$" & C_DEFAULT_RANGE)
            SQL = Replace(SQL, "{#fld_name}", Format(DateValue(ws.Name), "DD MM"))
           
            'Sql öffnen und das Resultat in die Check-Tabelle schreiben
            writeFullData wsCheck.Cells(1, colNr), openRs(SQL)
        End If
    Next ws
End Sub

'/**
' * Regulären Ausdruck, der die Sheetnamen prüft um herauszufinden, ob es sich um ein Datumssheet handelt
' * @return RegExp
' */
Private Property Get rxDataSheet() As Object
    Static rx As Object
    If rx Is Nothing Then
        Set rx = CreateObject("VBScript.RegExp")
        rx.Pattern = "^(\d{1,2})\.\s*(\S+)$"
    End If
    Set rxDataSheet = rx
End Property

 

[Inaktiver Nutzer]

Von Programm schreiben war ja auch nie die Rede zumal deine Lösung ja schon fertig war und nicht extra für mich entwickelt wurde. Etwas modifizieren und abspecken ist kein neu schreiben ;-)

Mal sehen wie ich mich da dursch wurschtl,werd das schon irgendwie hinkriegen.Trotzdem Danke

Lg Frank

P.S Überall,wo jetzt ne 0 steht sagt Excel was von falscher Formatierung oder es wäre ein Apostroph vorangestellt.Nichts dergleichen ist so