Excel vba - geef de celreferenties op basis van een vert.zoekfunctie.

[Goldfoxx]

Hoi,

Ik heb een excelbestand met een database met klantgegevens met daarnaast een tabblad met mutaties op deze klantgegevens. Zie bijgevoegd bestand voor een voorbeeld, (de originele database heeft veel meer regels en kolommen.)

Nu wil ik een macro maken die de mutaties automatisch verwerkt in de database. De loopfunctie hiervoor heb ik al geschreven, alleen ben ik nog op zoek naar het volgende:

In de macro moet hij op basis van het klantnummer en de kolom in het mutatieformulier de celreferentie vinden in de database.
Eigenlijk dus de in plaats de waarde die een vert.zoeken functie geeft moet ik de celreferentie (Bijv. "C3") terugkrijgen.

Met die referentie kan ik dan uiteindelijk de mutatie daarin doorvoeren in die cel.

Kunnen jullie mij helpen aan hoe dit het best op te pakken is?


Mutaties:

Klant nr. Omschrijving mutatie Kolom mutatie Kolumnr Nieuwe waarde
5 Adres B 2 Peperweg 3
6 Contactpersoon D 4 Jan-Peter
3 Wil mailing ontvangen E 5 Ja

Database:

Klantnr. Adres Postcode Contactpersoon Wil mailing ontvangen
1 Testweg 5 2165 JK Jan Ja
2 Driehoek 7 1562 JD Piet Ja
3 Kreta 4 1236 lS Klaas Nee
4 Mr. Meesterweg 9 1569 OS Greet Nee
5 Koekkoek 3 7612 KS Karin Ja
6 Leverworstweg 15 3458 KJ Marleen Nee

 

[Niels28]

Macro zoekt alle klantnummers en past datgene aan dat je op tabblad mutaties hebt aangegeven.

Sub vind_mutatie()

    For Each cl In Sheets("mutaties").Range("A2:A500").SpecialCells(2)
        With Sheets("database").Columns(1).SpecialCells(2)
            Set c = .Find(cl.Value)
            aanpassing = UCase(cl.Offset(0, 1).Value)
            
            Select Case aanpassing
                Case "ADRES"
                c.Offset(0, 1).Value = cl.Offset(0, 4).Value
                Case "CONTACTPERSOON"
                c.Offset(0, 3).Value = cl.Offset(0, 4).Value
                Case "WIL MAILING ONTVANGEN"
                c.Offset(0, 4).Value = cl.Offset(0, 4).Value
            End Select
            
        End With
    Next

End Sub

Niels

 

[Goldfoxx]

Macro zoekt alle klantnummers en past datgene aan dat je op tabblad mutaties hebt aangegeven.

Niels

Hoi, bedankt, maar is helaas niet wat ik zoek.

Jij definieert van te voren naar welke kolom hij moet gaan. Het originele bestand heeft echter rond de 40 kolommen die af en toe ook nog wijzigen. Hij moet dus daadwerkelijk de celreferentie ophalen van te voren op basis van de kolom die wordt weergegeven in `mutaties`.

 

[Niels28]

Kolom met klantnummer wel altijd hetzelfde?

 

[Goldfoxx]

Kolom met klantnummer wel altijd hetzelfde?

Klopt. De zoekwaarde is dus altijd het klantnummer en die bevind zich in beiden altijd in de eerste kolom.

De mutaties worden door een makro op deze manier uit een ander document gehaald, en nu wil ik dit dus automatisch kunnen laten muteren in de database.

 

[Niels28]

maakt het alleen maar makkelijker

Sub vind_mutatie()

    For Each cl In Sheets("mutaties").Range("A2:A500").SpecialCells(2)
        With Sheets("database").Columns(1).SpecialCells(2)
            Set c = .Find(cl.Value)

                c.Offset(0, cl.Offset(0, 3).Value - 1).Value = cl.Offset(0, 4).Value

        End With
    Next

End Sub

Niels

 

[Goldfoxx]

maakt het alleen maar makkelijker

Niels

Ik heb de code even aangepast naar het originele bestand, waarbij de kolomindeling een klein beetje anders is. Ook heb ik een controle ingebouwd of hij al verwerkt is, en zet hij een V neer in de kolom verwerkt als hij hem heeft aangepast. Ik ben niet zo heel bekwaam in vba, dus vergeef mij mijn eventuele onkunde

Ik krijg nu een foutmelding op de regel waar hij de waarde wijzigt in het stambestand. (voormalige database)

For Each cl In Sheets("Mutatieformulier").Range("A2:A10000").SpecialCells(2)
        With Sheets("Stambestand").Columns(1).SpecialCells(2)
            If IsEmpty(cl.Offset(0, 6)) = True Then
                Set c = .Find(cl.Value)
                    c.Offset(0, cl.Offset(0, 3).Value - 1).Value = cl.Offset(0, 5).Value
                    cl.Offset(0, 7).FormulaR1C1 = "V"
            End If
        End With
    Next

Juiste indeling van het originele mutatieformulier:

Klant nr. Datum Kolom Kolomgetal Gemuteerde cel Oude waarde Nieuwe waarde Verwerkt

 

[Niels28]

plaats even een voorbeeld bestandje waar dit instaat.

Ik zie dat je op kolom 7 controleert of deze leeg is en daarna en V in kolom 8 zet.
Bestaat het klantnummer wel?

Niels

 

[Goldfoxx]

plaats even een voorbeeld bestandje waar dit instaat.

Ik zie dat je op kolom 7 controleert of deze leeg is en daarna en V in kolom 8 zet.
Bestaat het klantnummer wel?

Niels

Er zaten nog 2 foutjes in de code, de verwijzing moest inderdaad kolom 8 zijn. dit is de werkende variant.

For Each cl In Sheets("Mutatieformulier").Range("A2:A10000").SpecialCells(2)
        With Sheets("Stambestand").Columns(1).SpecialCells(2)
            If IsEmpty(cl.Offset(0, 7)) = True Then
                Set c = .Find(cl.Value)
                    c.Offset(0, cl.Offset(0, 3).Value - 1).Value = cl.Offset(0, 6).Value
                    cl.Offset(0, 7).FormulaR1C1 = "V"
            End If
        End With
    Next

Is er een controle in te bouwen om onbekende debiteurnummers te negeren? Of liever nog te arceren?

Bij een normale verwijzing gaat mij dat wel lukken, maar met deze "for each" loop heb ik nog niet eerder gewerkt.

 

[Niels28]

For Each cl In Sheets("Mutatieformulier").Range("A2:A10000").SpecialCells(2)
        With Sheets("Stambestand").Columns(1).SpecialCells(2)
       
            If IsEmpty(cl.Offset(0, 7)) = True Then
                Set c = .Find(cl.Value, lookat:=xlWhole)
                    If Not c Is Nothing Then
                    c.Offset(0, cl.Offset(0, 3).Value - 1).Value = cl.Offset(0, 6).Value
                    cl.Offset(0, 7).FormulaR1C1 = "V"
                    Else
                    cl.Interior.Color = vbRed
                    End If
            End If
        End With
    Next

Niels

 

[Goldfoxx]

For Each cl In Sheets("Mutatieformulier").Range("A2:A10000").SpecialCells(2)
        With Sheets("Stambestand").Columns(1).SpecialCells(2)
       
            If IsEmpty(cl.Offset(0, 7)) = True Then
                Set c = .Find(cl.Value, lookat:=xlWhole)
                    If Not c Is Nothing Then
                    c.Offset(0, cl.Offset(0, 3).Value - 1).Value = cl.Offset(0, 6).Value
                    cl.Offset(0, 7).FormulaR1C1 = "V"
                    Else
                    cl.Interior.Color = vbRed
                    End If
            End If
        End With
    Next

Niels

Super, dat doet hem.

Erg bedankt!

 

[Niels28]

Zet je de vraag dan op opgelost.

Niels

 

[Goldfoxx]

Bij deze!