Excel & VBA

Das Makro durchläuft die Zeilen von lngEZ bis lngLZ in Spalte intS. Immer wenn es in den restlichen Zeilen bis lngLZ eine gleiche Eintragung wie in der aktuellen Zelle findet, prüft es, ob auch die Eintragungen in den anderen beiden Spalten identisch sind. Wenn ja, trägt es in der Spalte intSZ in der aktuellen Zeile ein: "Mehrfach vorhanden." und in den anderen identischen Zeilen die einzelnen Werte der Zellen.

Sub Filtern() '----- Deklaration ------------------- Dim lngI As Long, lngJ As Long, lngEZ As Long, lngLZ As Long Dim intS As Integer, intS1 As Integer, intS2 As Integer, intSZ As Integer Dim strWert As String, strErsterWert As String, strZweiterWert As String '----- Variablen ---------------------- 'Die folgenden Zahlen müssen an die Tabelle angepaßt werden: lngEZ = 4 'erste Zeile mit Daten lngLZ = 20 'letzte Zeile mit Daten intS = 2 'erste Spalte mit Daten intS1 = 3 'Erste Spalte, die durchsucht werden soll intS2 = 4 'Zweite Spalte, die durchsucht werden soll intSZ = 5 'Spalte, in die die doppelten Daten eingelesen werden sollen For lngI = lngEZ To lngLZ strWert = Cells(lngI, intS).Value strErsterWert = Cells(lngI, intS1).Value strZweiterWert = Cells(lngI, intS2).Value For lngJ = lngI + 1 To lngLZ If Cells(lngJ, intS).Value = strWert _ And Cells(lngJ, intS1).Value = strErsterWert _ And Cells(lngJ, intS2).Value = strZweiterWert _ And Cells(lngJ, intSZ) = "" Then Cells(lngI, intSZ) = "Mehrfach vorhanden." Cells(lngJ, intSZ) = "Mehrfach vorhanden: " & strWert & ", " & strErsterWert & ", " & strZweiterWert End If Next lngJ Next lngI End Sub

Hier gibt es ein Add-In dazu:

downloads.php?id=589

Siehe Beispiele in der Beispieldatei.

Diese Variante geht zwar, ist aber hoffnungslos veraltet. Eine neue Variante ist in Arbeit.

Hier ist ein Ansatzpunkt, der sicher noch zu verbessern geht:

Sub sudoku() Dim intS As Integer, intS1 As Integer Dim lngZ As Long, lngZ1 As Long Dim intZaehler As Integer Dim bolVorhanden As Boolean Dim bytZ As Byte, bytI As Byte Dim lngBeginn As Long, lngEnde As Long Dim intBeginn As Integer, intEnde As Integer Dim strRange As String Dim objZelle As Object Dim bytMaximum As Byte Dim intVersuche As Integer, intVersuchsZaehler As Integer bytMaximum = 9 intVersuche = 600 lngBeginn = 10 lngEnde = 18 intBeginn = 2 intEnde = 10 Cells(3, 11).ClearContents Cells(2, 11) = Now Cells(2, 11).NumberFormat = "h:mm:ss" intVersuchsZaehler = 0 VONVORN: intVersuchsZaehler = intVersuchsZaehler + 1 Cells(1, 11) = intVersuchsZaehler intZaehler = 0 Range(Cells(10, 2), Cells(18, 10)).Clear 'Alle Zeilen durchlaufen: For lngZ = lngBeginn To lngEnde 'In der Zeile jede Zelle ausfüllen For intS = intBeginn To intEnde 'So lange Zufallszahl bilden, bis bolVorhanden False bleibt: Do intZaehler = intZaehler + 1 bytZ = Int((bytMaximum * Rnd) + 1) bolVorhanden = False 'Prüfung des kleinen Quadrates: strRange = "" If lngZ >= 10 And lngZ <= 12 And intS >= 2 And intS <= 4 Then strRange = Range(Cells(10, 2), Cells(12, 4)).Address(False, False) ElseIf lngZ >= 10 And lngZ <= 12 And intS >= 5 And intS <= 7 Then strRange = Range(Cells(10, 5), Cells(12, 7)).Address(False, False) ElseIf lngZ >= 10 And lngZ <= 12 And intS >= 8 And intS <= 10 Then strRange = Range(Cells(10, 8), Cells(12, 10)).Address(False, False) ElseIf lngZ >= 13 And lngZ <= 15 And intS >= 2 And intS <= 4 Then strRange = Range(Cells(13, 2), Cells(15, 4)).Address(False, False) ElseIf lngZ >= 13 And lngZ <= 15 And intS >= 5 And intS <= 7 Then strRange = Range(Cells(13, 5), Cells(15, 7)).Address(False, False) ElseIf lngZ >= 13 And lngZ <= 15 And intS >= 8 And intS <= 10 Then strRange = Range(Cells(13, 8), Cells(15, 10)).Address(False, False) ElseIf lngZ >= 16 And lngZ <= 18 And intS >= 2 And intS <= 4 Then strRange = Range(Cells(16, 2), Cells(18, 4)).Address(False, False) ElseIf lngZ >= 16 And lngZ <= 18 And intS >= 5 And intS <= 7 Then strRange = Range(Cells(16, 5), Cells(18, 7)).Address(False, False) ElseIf lngZ >= 16 And lngZ <= 18 And intS >= 8 And intS <= 10 Then strRange = Range(Cells(16, 8), Cells(18, 10)).Address(False, False) End If If strRange <> "" Then For Each objZelle In Range(strRange) If objZelle = bytZ Then bolVorhanden = True Next End If 'Zeile prüfen: For intS1 = intBeginn To intS - 1 If Cells(lngZ, intS1) = bytZ Then bolVorhanden = True Next 'Spalte prüfen: For lngZ1 = lngBeginn To lngZ - 1 If Cells(lngZ1, intS) = bytZ Then bolVorhanden = True Next If intZaehler = intVersuche Then GoTo VONVORN Loop Until bolVorhanden = False Cells(lngZ, intS) = bytZ Next Next For bytI = 2 To 10: Columns(bytI).ColumnWidth = 2.86: Next Rows("10:18").RowHeight = 18.75 With Range(Cells(lngBeginn, intBeginn), Cells(lngEnde, intEnde)) .HorizontalAlignment = xlCenter .Borders(xlEdgeLeft).Weight = xlMedium .Borders(xlEdgeTop).Weight = xlMedium .Borders(xlEdgeBottom).Weight = xlMedium .Borders(xlEdgeRight).Weight = xlMedium .Borders(xlInsideVertical).Weight = xlThin .Borders(xlInsideHorizontal).Weight = xlThin End With With Range(Cells(10, 2), Cells(12, 4)) .Borders(xlEdgeLeft).Weight = xlMedium .Borders(xlEdgeTop).Weight = xlMedium .Borders(xlEdgeBottom).Weight = xlMedium .Borders(xlEdgeRight).Weight = xlMedium .Borders(xlInsideVertical).Weight = xlThin .Borders(xlInsideHorizontal).Weight = xlThin End With With Range(Cells(10, 5), Cells(12, 7)) .Borders(xlEdgeLeft).Weight = xlMedium .Borders(xlEdgeTop).Weight = xlMedium .Borders(xlEdgeBottom).Weight = xlMedium .Borders(xlEdgeRight).Weight = xlMedium .Borders(xlInsideVertical).Weight = xlThin .Borders(xlInsideHorizontal).Weight = xlThin End With With Range(Cells(10, 8), Cells(12, 10)) .Borders(xlEdgeLeft).Weight = xlMedium .Borders(xlEdgeTop).Weight = xlMedium .Borders(xlEdgeBottom).Weight = xlMedium .Borders(xlEdgeRight).Weight = xlMedium .Borders(xlInsideVertical).Weight = xlThin .Borders(xlInsideHorizontal).Weight = xlThin End With With Range(Cells(13, 2), Cells(15, 4)) .Borders(xlEdgeLeft).Weight = xlMedium .Borders(xlEdgeTop).Weight = xlMedium .Borders(xlEdgeBottom).Weight = xlMedium .Borders(xlEdgeRight).Weight = xlMedium .Borders(xlInsideVertical).Weight = xlThin .Borders(xlInsideHorizontal).Weight = xlThin End With With Range(Cells(13, 5), Cells(15, 7)) .Borders(xlEdgeLeft).Weight = xlMedium .Borders(xlEdgeTop).Weight = xlMedium .Borders(xlEdgeBottom).Weight = xlMedium .Borders(xlEdgeRight).Weight = xlMedium .Borders(xlInsideVertical).Weight = xlThin .Borders(xlInsideHorizontal).Weight = xlThin End With With Range(Cells(13, 8), Cells(15, 10)) .Borders(xlEdgeLeft).Weight = xlMedium .Borders(xlEdgeTop).Weight = xlMedium .Borders(xlEdgeBottom).Weight = xlMedium .Borders(xlEdgeRight).Weight = xlMedium .Borders(xlInsideVertical).Weight = xlThin .Borders(xlInsideHorizontal).Weight = xlThin End With With Range(Cells(16, 2), Cells(18, 4)) .Borders(xlEdgeLeft).Weight = xlMedium .Borders(xlEdgeTop).Weight = xlMedium .Borders(xlEdgeBottom).Weight = xlMedium .Borders(xlEdgeRight).Weight = xlMedium .Borders(xlInsideVertical).Weight = xlThin .Borders(xlInsideHorizontal).Weight = xlThin End With With Range(Cells(16, 5), Cells(18, 7)) .Borders(xlEdgeLeft).Weight = xlMedium .Borders(xlEdgeTop).Weight = xlMedium .Borders(xlEdgeBottom).Weight = xlMedium .Borders(xlEdgeRight).Weight = xlMedium .Borders(xlInsideVertical).Weight = xlThin .Borders(xlInsideHorizontal).Weight = xlThin End With With Range(Cells(16, 8), Cells(18, 10)) .Borders(xlEdgeLeft).Weight = xlMedium .Borders(xlEdgeTop).Weight = xlMedium .Borders(xlEdgeBottom).Weight = xlMedium .Borders(xlEdgeRight).Weight = xlMedium .Borders(xlInsideVertical).Weight = xlThin .Borders(xlInsideHorizontal).Weight = xlThin End With Cells(3, 11) = Now Cells(4, 11) = Cells(3, 11) - Cells(2, 11) Cells(3, 11).NumberFormat = "h:mm:ss" Cells(4, 11).NumberFormat = "h:mm:ss" End Sub

Eine Datei dazu finden Sie in den Beispieldateien (sudoku.zip)