Controle in kolom in meerdere tabbladen

[Interface]

Voor een bestand wat ik heb wil ik een controle toevoegen.

De controle heeft betrekking op kolom "d". In de deze kolom staan ongeveer 300 getallen met een cijferlengte van vijftien charcaters. Nu wil ik dat er een textbox verschijnt als de waarde op hetzelfde blad en in de zelfde kolom nog een keer voorkomt. Om het extra moeilijk te maken, moet controle ook voor de twee andere tabbladen gedaan worden(op deze tabbladen ook in kolom "d")

Dus als op werkblad 6 in "d9" een waarde staat die ook bijv. in tabblad 8 "d273" voorkomt moet er een textbox verschijnen met het werkblad nr.(of naam) en de locatie.

 

[enijhuis]

Hiermee zou het moeten gaan.
Zie de bijlage voor een werkend voorbeeld.

Public Sub CheckDubbelen()

    Const COL_VALUES = "D"
    Const ROW_START = 3
    Const COL_VALUES_TMP = "A"
    Const COL_ADDRESS_TMP = "B"
    
    Dim oSheet As Worksheet
    Dim oSelection As Range
    Dim oCell As Range
    Dim oValues As Range
    Dim iRow As Integer
    
    Set oSelection = Selection
        
    'Kopieer de waarden
    ShTmp.Columns(COL_VALUES_TMP & ":" & COL_ADDRESS_TMP).ClearContents
    
    For Each oSheet In ThisWorkbook.Worksheets
    
        Select Case oSheet.Name
        
            Case "Blad1", "Blad2", "Blad3"
                'Kopieer de waarden + celadressen uit het werkblad naar ShTmp
                
                Set oValues = oSheet.Range(COL_VALUES & ROW_START, _
                COL_VALUES & oSheet.Range(COL_VALUES & ROW_START).End(xlDown).Row)
                
                For Each oCell In oValues
                
                    iRow = iRow + 1
                    
                    ShTmp.Range(COL_VALUES_TMP & iRow) = oCell
                    ShTmp.Range(COL_ADDRESS_TMP & iRow) = oSheet.Name & "!" & oCell.Address
                
                Next
                
            Case Else 'sla andere werkbladen over
        End Select
    Next
    
    'Sorteer de waarden
    ShTmp.Activate
    ShTmp.Range(COL_VALUES_TMP & 1 & ":" & COL_ADDRESS_TMP & iRow).Sort Key1:=Range(COL_VALUES_TMP & 1)
    
    oSelection.Worksheet.Activate
    
    'Toon de dubbelen:
    For Each oCell In ShTmp.Range(COL_VALUES_TMP & 1 & ":" & COL_VALUES_TMP & iRow)
        If oCell = oCell.Offset(1, 0) Then
            MsgBox "De waarde '" & oCell & "' is meerdere keren aangetroffen." & vbCrLf & _
                vbCrLf & "Locatie:" & vbCrLf & _
                   oCell.Offset(0, 1) & vbCrLf & _
                   oCell.Offset(1, 1), vbInformation
        End If
    Next
    
End Sub

 

[snb]

Of zo

Sub voorkomend()
  For j = 1 To 3
    sp = WorksheetFunction.Transpose(Sheets(j).Columns(4).SpecialCells(xlCellTypeConstants))
    If j = 1 Then sq = sp
    If j = 2 Then st = sp
  Next
    
  For j = 1 To UBound(sp)
    If UBound(Filter(sq, sp(j))) > -1 Then c0 = UBound(Filter(sq, sp(j))) + 1 & " keer aangetroffen in Blad2"
    If UBound(Filter(st, sp(j))) > -1 Then c0 = c0 & vbCr & UBound(Filter(sq, sp(j))) + 1 & " keer aangetroffen in Blad3"
    MsgBox c0, , sp(j)
  Next
End Sub

 

[enijhuis]

Hoi snb,

Als ik jouw code run krijg ik gelijk de volgende foutmelding:

err.description:
Eigenschap Transpose van klasse WorksheetFunction kan niet worden opgehaald.

Ik zie het al: er stond een lege cel tussen de titel en de opsomming van de waarden: bij Transpose mogen dergelijke cellen niet voorkomen in een range.

 

[snb]

Is natuurlijk te ondervangen met

For j = 1 To 3
  Sheets(j).Columns(4).SpecialCells(xlCellTypeBlanks).delete
  sp = WorksheetFunction.Transpose(Sheets(j).Columns(4).SpecialCells(xlCellTypeConstants))
  If j = 1 Then sq = sp
  If j = 2 Then st = sp
Next

 

[enijhuis]

Weer wat geleerd..

 

[Interface]

Mooi stukje code snb!

Echter heb ik het bestand deels aangepast, nu is de controle alleen nog maar nodig op 1 werkblad.

In de bijlage een bestand, met daarin een voorbeeld. Ik ben al aan de slag gegaan. Nu ben ik niet zo onderlegd als jullie, maar het is ook niet dat ik helemaal niks weet. Eén ding begrijp ik echter niet, waarom werkt mijn code niet in het bijgevoegde bestand?

 

[Interface]

vorige reactie

Van de declaratie in het vorige bestand klopt niets, dat weet ik wel:$ Ik hoop niet dat jullie daarover struikelen...

Ik bedoel meer te zeggen, waarom hou ik nog steeds regels over die meerdere keren voorkomen?

 

[snb]

Wat ik niet begrijp is, waarom je niets met de gegeven suggesties doet.

 

[Interface]

Het is niet dat ik dat niet wil...

Ik ga het zerker gebruiken, alleen had ik nog de vraag waarom de code van mij niet werkt.

 

[Interface]

ik heb het anders gedaan en nu werkt het

Sub joas()

Dim intAantal As Integer
Dim intAantalDelete As Integer
Dim varVerwijder
Dim teveel As Object


Application.ScreenUpdating = False


For intAantal = 3 To Range("b3", Range("b3").End(xlDown)).Count
varVerwijder = Range("b3", Range("b" & intAantal)).Address
Range(varVerwijder).Sort key1:=Range("b3")
For intAantalDelete = 3 To Range("b3", Range("b3").End(xlDown)).Count
For Each teveel In Range(varVerwijder)
Next
If Range("b2").Value = Range("b3").Value Then Rows(2).Delete
If Range("b" & intAantalDelete).Value = Range("b" & intAantalDelete).Offset(1, 0).Value Then Rows(intAantalDelete).Offset(1, 0).Delete

Next
Next

Rows(2).Select
Selection.Insert

terugplaatsen = Range("b3").End(xlDown).Address
Range(terugplaatsen, Range(terugplaatsen).Offset(0, 12)).Select
Selection.Copy
Range("b2").Select
ActiveSheet.Paste
Range(terugplaatsen, Range(terugplaatsen).Offset(0, 12)).Select
Selection.Delete


Application.ScreenUpdating = True

End Sub

Niet zo goed als jullie macro's, maar ik ben blij dat het toch mijzelf gelukt is. Jammer dat ik geen antwoord heb gekregen op mijn laatste vraag. Wat ik ook niet helemaal begrijp is dat ubound en transponeren.