Lijnen in Excel kleuren (als waarde voorkomt in ander tabblad van Excel)

Status
Niet open voor verdere reacties.
X

xenium

Gebruiker
Lid geworden
1 jul 2007
Berichten
150
Beste,
Op mijn werk hebben wij 2 programma's waaruit wij het een lijst kunnen maken van het werk dat we gaan moeten doen.
Deze 2 lijsten worden geëxporteerd naar Excel in 2 tabbladen (vb Kleur en Vergelijk).
De ene lijst is een real-time momentopname (dus verschilt van dag tot dag of van week tot week), de andere lijst is zeer uigebreide lijst waarin de momentopname van het doorgestuurde werk is en dus niet meer veranderd. In deze laaste lijst (wat ik dus wil gaan kleuren wat nog gedaan moet worden) staat heel veel informatie en het is bijna onbegonnen werk om alles manueel op te zoeken wat nog gedaan moet worden.
Nu was er op een vergadering aangehaald om dit op te lossen met een verticaal zoeken, maar ook dit neemt wat tijd in beslag en ik had samen met een collega proberen een oplossing te zoeken, door middel van de lange lijst te kleuren van wat nog gedaan moet worden.
In Excel heb ik ondertussen een werkend voorbeeld, maar ik slaag er maar niet in om de module "Kleur" om te zetten naar VB.NET code.
Hopelijk kunnen jullie mij hiermee helpen. Ik heb mij gebasseerd op de volgende link: http://msdn.microsof...y/e4x1k99a.aspx
De module in Excel ziet er zo uit:

Code: 
 Sub Kleuren(TeKleurenBlad As String, TeDoorzoekenBlad As String, Aantalkolommen As Integer, Kleur As String)
    Dim kleurindex As Integer
    kleurindex = KleurBepalen(Kleur)
    Dim sq As Variant, i As Long, c As Variant, firstaddress As Variant
    Dim Gebruikersnaam As String
    Dim AantalGekleurdeLijnen As Integer
    Dim StartTijd As Date
    Dim EindTijd As Date
    StartTijd = Timer
    Sheets(TeKleurenBlad).Select
    With Sheets(TeDoorzoekenBlad)
    sq = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    For i = 1 To UBound(sq)
    With Sheets(TeKleurenBlad)
    Set c = .Columns(1).Find(sq(i, 1), , xlValues, xlWhole)
    If Not c Is Nothing Then
    firstaddress = c.Address
    Do
    c.Resize(, Aantalkolommen).Interior.ColorIndex = kleurindex
    Set c = Columns(1).FindNext(c)
    Loop While Not c Is Nothing And c.Address <> firstaddress
    End If
    End With
    Next i
    End With
    EindTijd = Timer
    Gebruikersnaam = Get_User_Name()
    With Sheets(TeKleurenBlad)
    AantalGekleurdeLijnen = CountByColor(.Range("A2:A" & Cells(.Rows.Count, 1).End(xlUp).Row), kleurindex)
    End With
    MsgBox Gebruikersnaam & ", alles is gekleurd. Er zijn " & AantalGekleurdeLijnen & " lijnen gekleurd in " & EindTijd - StartTijd & " seconden.", vbOKOnly, "Done"

Ik heb nu reeds geprobeerd om dit om te zetten naar VB.NET en voorlopig heb ik dit:


Code: 
  Sub Kleuren(ByVal Pad As String, ByVal wb As Excel.Workbook, ByVal TeKleurenBlad As String, ByVal TeDoorzoekenBlad As String, ByVal Aantalkolommen As Integer, ByVal Kleur As String)
    Dim kleurindex As Integer
    kleurindex = KleurBepalen(Kleur)
    Dim sq As Excel.Range, i As Long, c As Object, firstaddress As Object
    Dim currentFind As Excel.Range = Nothing
    Dim firstFind As Excel.Range = Nothing
    Dim Gebruikersnaam As String
    Dim AantalGekleurdeLijnen As Integer
    Dim StartTijd As Date
    Dim EindTijd As Date
    Dim strBericht As String
    Dim varLaasteRij As Long
    Dim varLaatsteRij2 As Long
    Dim varLaatsteKolom As Long
    Dim waarde As Object
    Dim KleurenRange As Excel.Range
    Dim KolomLetter As String
    Dim wsKleur As Excel.Worksheet
    Dim wsVergelijk As Excel.Worksheet
    StartTijd = Now
    wsKleur = wb.Sheets(TeKleurenBlad)
    wsVergelijk = wb.Sheets(TeDoorzoekenBlad)
    wsKleur.Select()
    With wsKleur
    varLaatsteRij2 = .Cells(2, 1).end(Excel.XlDirection.xlDown).row
    varLaatsteKolom = .Cells(2, .Columns.Count).End(Excel.XlDirection.xlToLeft).Column
    KolomLetter = Chr(varLaatsteKolom + 64)
    KleurenRange = .Range("A2:" & KolomLetter & varLaatsteRij2)
    End With
    With wsVergelijk
    varLaasteRij = .Cells(2, 1).end(Excel.XlDirection.xlDown).row
    sq = .Range("A2:A" & varLaasteRij)
    For i = 2 To varLaasteRij
    waarde = .Cells(i, 1)
    With wsKleur
    currentFind = KleurenRange.Find(waarde, , Excel.XlFindLookIn.xlValues, Excel.XlLookAt.xlWhole)
    While Not currentFind Is Nothing
    If firstFind Is Nothing Then
    firstFind = currentFind
    ElseIf currentFind.Address = firstFind.Address Then
    Exit While
    End If
    With currentFind
    .Resize(, Aantalkolommen).Interior.ColorIndex = kleurindex
    End With
    currentFind = KleurenRange.FindNext(currentFind)
    End While
    End With
    Next i
    End With
    EindTijd = Now
    Gebruikersnaam = GetUserName()
    With wsKleur
    AantalGekleurdeLijnen = CountByColor(Pad, wb, TeKleurenBlad, .Range("A2:A" & .Cells(.Rows.Count, 1).End(Excel.XlDirection.xlDown).Row), kleurindex)
    End With
    strBericht = Gebruikersnaam & ", alles is gekleurd. Er zijn " & AantalGekleurdeLijnen & " lijen gekleurd."
    MsgBox(strBericht, vbOKOnly, "Done")
    End Sub

Het Excel bestand dat ik toegevoegd heb, is een voorbeeld. Bij ons op het werk werken wij met veel grotere bestanden en op deze bestanden staat ook veel meer info.
Het is dus bedoeling dat het blad "Kleur" gekleurd wordt, als de waarde voorkomt in "Vergelijk" (telkens de A-kolom).

Echter, de pc doet er gigantisch lang over en hij doet eigenlijk niets. Kan iemand mij hiermee helpen?
Alvast bedankt.

Bekijk bijlage UZ Hulpmiddelen.rar
Bekijk bijlage test.xlsm
 
Sorry, maar ik vind de code zonder inspringpunten op de juiste plekken nogal onleesbaar en dat ontneemt me de lust om er eens serieus naar te kijken.
 
Beste,

Sorry, had mijn vraag hier in word gezet en dan gekopieerd...
Hier volgt een tweede poging:

Men module in Excel:

Code: 
Option Explicit

Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long
Function Get_User_Name()

Dim lpBuff As String * 25
Dim ret As Long, UserName As String

ret = GetUserName(lpBuff, 25)
UserName = Left(lpBuff, InStr(lpBuff, Chr(0)) - 1)

Get_User_Name = UserName
End Function


Sub AantalLijnen(TeKleurenBlad As String, TeDoorzoekenBlad As String)

    Dim varLaatsteRijTeKleurenBlad As Variant
    Dim varLaatsteRijTeDoorzoekenBlad As Variant
    Dim strBericht As String
    
    Sheets(TeKleurenBlad).Select
    Cells(2, 1).Select
    Selection.End(xlDown).Select
    varLaatsteRijTeKleurenBlad = Selection.Row
    Sheets(TeDoorzoekenBlad).Select
    Cells(2, 1).Select
    Selection.End(xlDown).Select
    varLaatsteRijTeDoorzoekenBlad = Selection.Row
    
    strBericht = "Er worden " & varLaatsteRijTeKleurenBlad & " lijnen uit " & TeKleurenBlad & " gezocht in " & varLaatsteRijTeDoorzoekenBlad & " lijnen uit " & TeDoorzoekenBlad & "."
    strBericht = strBericht & vbNewLine & "Dit kan even duren."
    MsgBox strBericht, vbOKOnly + vbCritical, "Wachten"
    
End Sub

Sub Kleuren(TeKleurenBlad As String, TeDoorzoekenBlad As String, Aantalkolommen As Integer, Kleur As String)
    Dim kleurindex As Integer
    kleurindex = KleurBepalen(Kleur)
    Dim sq As Variant, i As Long, c As Variant, firstaddress As Variant
    Dim Gebruikersnaam As String
    Dim AantalGekleurdeLijnen As Integer
    Dim StartTijd As Date
    Dim EindTijd As Date
    
    StartTijd = Timer
    Sheets(TeKleurenBlad).Select
    With Sheets(TeDoorzoekenBlad)
        sq = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        For i = 1 To UBound(sq)
            With Sheets(TeKleurenBlad)
                Set c = .Columns(1).Find(sq(i, 1), , xlValues, xlWhole)
                If Not c Is Nothing Then
                    firstaddress = c.Address
                    Do
                        c.Resize(, Aantalkolommen).Interior.ColorIndex = kleurindex
                        Set c = Columns(1).FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> firstaddress
                End If
            End With
        Next i
    End With
    EindTijd = Timer
    Gebruikersnaam = Get_User_Name()
    With Sheets(TeKleurenBlad)
        AantalGekleurdeLijnen = CountByColor(.Range("A2:A" & Cells(.Rows.Count, 1).End(xlUp).Row), kleurindex)
    End With
    MsgBox Gebruikersnaam & ", alles is gekleurd. Er zijn " & AantalGekleurdeLijnen & " lijnen gekleurd in " & EindTijd - StartTijd & " seconden.", vbOKOnly, "Done"
End Sub

Function CountByColor(InputRange As Range, intColorindex As Integer) As Long
Dim cl As Range, TempCount As Long
    TempCount = 0
    For Each cl In InputRange.Cells
        If cl.Interior.ColorIndex = intColorindex Then
            TempCount = TempCount + 1
        End If
    Next cl
    Set cl = Nothing
    CountByColor = TempCount
End Function

Function KleurBepalen(Kleurnaam As String) As Integer

    Dim intKleurindex As Integer

    Select Case LCase(Kleurnaam)
        Case "blauw"
            intKleurindex = 33
        Case "groen"
            intKleurindex = 4
        Case "rood"
            intKleurindex = 3
        Case "geel"
            intKleurindex = 6
        Case "oranje"
            intKleurindex = 46
        Case "paars"
            intKleurindex = 39
        Case "grijs"
            intKleurindex = 48
    End Select
    
    KleurBepalen = intKleurindex
End Function

De module in VB.NET:

Code: 
Imports Excel = Microsoft.Office.Interop.Excel

Module mdlKleur
    Declare Function GetUserName Lib "advapi32.dll" Alias _
     "GetUserNameA" (ByVal lpBuffer As String, _
     ByRef nSize As Integer) As Integer

    Public Function GetUserName() As String
        Dim iReturn As Integer
        Dim userName As String
        userName = New String(CChar(" "), 50)
        iReturn = GetUserName(userName, 50)
        GetUserName = userName.Substring(0, userName.IndexOf(Chr(0)))
    End Function


    Sub AantalLijnen(ByVal Pad As String, ByVal wb As Excel.Workbook, ByVal TeKleurenBlad As String, ByVal TeDoorzoekenBlad As String)

        Dim varLaatsteRijTeKleurenBlad As Long
        Dim varLaatsteRijTeDoorzoekenBlad As Long
        Dim strBericht As String
        'Dim xlCellTypeLastCell As Microsoft.Office.Interop.Excel.XlCellType


        Dim ws As Excel.Worksheet

        ws = wb.Sheets(TeKleurenBlad)
        With ws
            varLaatsteRijTeKleurenBlad = .Cells(2, 1).end(Excel.XlDirection.xlDown).row
        End With

        ws = wb.Sheets(TeDoorzoekenBlad)
        With ws
            varLaatsteRijTeDoorzoekenBlad = .Cells(2, 1).end(Excel.XlDirection.xlDown).row
        End With


        strBericht = "Er worden " & varLaatsteRijTeKleurenBlad & " lijnen uit " & TeKleurenBlad & " gezocht in " & varLaatsteRijTeDoorzoekenBlad & " lijnen uit " & TeDoorzoekenBlad & "."
        strBericht = strBericht & vbNewLine & "Dit kan even duren."
        MsgBox(strBericht, vbOKOnly + vbCritical, "Wachten")

    End Sub

    Sub Kleuren(ByVal Pad As String, ByVal wb As Excel.Workbook, ByVal TeKleurenBlad As String, ByVal TeDoorzoekenBlad As String, ByVal Aantalkolommen As Integer, ByVal Kleur As String)
        Dim kleurindex As Integer
        kleurindex = KleurBepalen(Kleur)
        Dim sq As Excel.Range, i As Long, c As Object, firstaddress As Object
        Dim currentFind As Excel.Range = Nothing
        Dim firstFind As Excel.Range = Nothing
        Dim Gebruikersnaam As String
        Dim AantalGekleurdeLijnen As Integer
        Dim StartTijd As Date
        Dim EindTijd As Date
        Dim strBericht As String
        Dim varLaasteRij As Long
        Dim varLaatsteRij2 As Long
        Dim varLaatsteKolom As Long
        Dim waarde As Object
        Dim KleurenRange As Excel.Range
        Dim KolomLetter As String

        Dim wsKleur As Excel.Worksheet
        Dim wsVergelijk As Excel.Worksheet

        'StartTijd = Timer
        StartTijd = Now


        wsKleur = wb.Sheets(TeKleurenBlad)
        wsVergelijk = wb.Sheets(TeDoorzoekenBlad)

        wsKleur.Select()

        With wsKleur
            varLaatsteRij2 = .Cells(2, 1).end(Excel.XlDirection.xlDown).row
            varLaatsteKolom = .Cells(2, .Columns.Count).End(Excel.XlDirection.xlToLeft).Column
            KolomLetter = Chr(varLaatsteKolom + 64)
            KleurenRange = .Range("A2:" & KolomLetter & varLaatsteRij2)
        End With

        With wsVergelijk
            '.Cells(2, 1).end(Excel.XlDirection.xlDown).row
            'sq = .Range("A2:A" & .Cells(.Rows.Count, 1).End(Excel.XlDirection.xlDown).Row)
            varLaasteRij = .Cells(2, 1).end(Excel.XlDirection.xlDown).row

            sq = .Range("A2:A" & varLaasteRij)

            For i = 2 To varLaasteRij
                waarde = .Cells(i, 1)
                With wsKleur
                    'c = .Columns(1).Find((waarde), , Excel.XlFindLookIn.xlValues, Excel.XlLookAt.xlWhole)
                    'If Not c Is Nothing Then
                    '    firstaddress = c.Address
                    '    Do
                    '        c.Resize(, Aantalkolommen).Interior.ColorIndex = kleurindex
                    '        c = .Columns(1).FindNext(c)
                    '    Loop While Not c Is Nothing And c.Address <> firstaddress
                    'End If
                    'currentFind = KleurenRange.Find(waarde, , Excel.XlFindLookIn.xlValues, Excel.XlLookAt.xlPart, Excel.XlSearchOrder.xlByRows, Excel.XlSearchDirection.xlNext, False)
                    currentFind = KleurenRange.Find(waarde, , Excel.XlFindLookIn.xlValues, Excel.XlLookAt.xlWhole)
                    While Not currentFind Is Nothing
                        If firstFind Is Nothing Then
                            firstFind = currentFind
                        ElseIf currentFind.Address = firstFind.Address Then
                            Exit While
                        End If
                        With currentFind
                            .Resize(, Aantalkolommen).Interior.ColorIndex = kleurindex
                        End With
                        currentFind = KleurenRange.FindNext(currentFind)
                    End While
                End With
            Next i
        End With

        'EindTijd = Timer
        EindTijd = Now
        Gebruikersnaam = GetUserName()
        With wsKleur
            AantalGekleurdeLijnen = CountByColor(Pad, wb, TeKleurenBlad, .Range("A2:A" & .Cells(.Rows.Count, 1).End(Excel.XlDirection.xlDown).Row), kleurindex)
        End With


        strBericht = Gebruikersnaam & ", alles is gekleurd. Er zijn " & AantalGekleurdeLijnen & " lijen gekleurd."
        MsgBox(strBericht, vbOKOnly, "Done")

    End Sub

    Function CountByColor(ByVal pad As String, ByVal wb As Excel.Workbook, ByVal TeKleurenBlad As String, ByVal InputRange As Excel.Range, ByVal intColorindex As Integer) As Long

        Dim ws As Excel.Worksheet

        ws = wb.Worksheets(TeKleurenBlad)

        Dim cl As Excel.Range, TempCount As Long
        TempCount = 0
        For Each cl In InputRange.Cells
            If cl.Interior.ColorIndex = intColorindex Then
                TempCount = TempCount + 1
            End If
        Next cl
        cl = Nothing
        CountByColor = TempCount


    End Function

    Function KleurBepalen(ByVal Kleurnaam As String) As Integer

        Dim intKleurindex As Integer

        Select Case LCase(Kleurnaam)
            Case "blauw"
                intKleurindex = 33
            Case "groen"
                intKleurindex = 4
            Case "rood"
                intKleurindex = 3
            Case "geel"
                intKleurindex = 6
            Case Else
                intKleurindex = 46
        End Select

        KleurBepalen = intKleurindex
    End Function

End Module

Ik hoop dat dit iets beter is. Men project in VB.NET heb ik tevens ook toegevoegd.
 
Dat ziet er inderdaad heel wat beter uit :thumb:
 
Hey,

Ik raak er maar niet uit, hoe ik nu kan bepalen dat hij enkel de gevulde lijnen (in de A kolom) moet kleuren/bestuderen. Eenmaal hier voorbij, kleurt hij alle lege lijnen en dit moet niet.

Heeft er iemand enig idee hoe ik dit moet oplossen?

Alvast bedankt.
 
Hey,

Heeft er iemand een oplossing hoe ik dit moet aanpakken?
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan