Automatisch aanpas script

[HansolD]

Goede morgen,

Om mijn werkzaamheden makkelijker te maken ben ik bezig om een script te maken voor het automatisch aanpassen van een hoop bestanden. Ik kom een heel eind met mijn nihile programmeer ervaring maar de laatste beetjes willen me steeds niet lukken.

Het script heeft als bedoeling op verschillende werkbladen opzoek te gaan naar een willekeurige tekst en als deze gevonden is de complete regel te overschrijven inclusief de regel erboven.

De waarde waar op gezocht moet worden komt meerdere keren voor op elk werkblad.

Tot nu toe heb ik het zover voor elkaar dat hij steeds wel de eerste waarde veranderd. Maar daarna pakt hij dezelfde row op elke tab om te overschrijven.

Kunnen jullie me hiermee helpen?

Groeten Hansol.

Dim i As Integer
    Dim searchStr As String
    Dim rowNumber
    Dim sheetnr As Integer
    Dim rFound As String
    
    i = 0
    sheetnr = 1
    searchStr = "Zoekstring"

    For Each Worksheet In ActiveWorkbook.Worksheets
        i = i + 1
        On Error Resume Next
    Next Worksheet
    
    On Error Resume Next
    
    Dim lastRow As Long
    Dim strRowNoList As String
    
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row  'Search Column A for the last used row.
    Do Until sheetnr = (i + 1)                      'Loops through all worksheets
    
With Worksheets(1).Range("A")
    Set rowNumber = ActiveSheet.Range("A").Find(searchStr, LookIn:=xlValues).Cells.Row
    If Not rowNumber Is Nothing Then
        firstAddress = rowNumber
        Do
                                                    'Sets the cell numbers which need to be edited
                Workbooks.Item(1).Sheets.Item(sheetnr).Range("A" & rowNumber) = "Zoekstring"
                Workbooks.Item(1).Sheets.Item(sheetnr).Range("B" & rowNumber) = "Ja"
                Workbooks.Item(1).Sheets.Item(sheetnr).Range("C" & rowNumber) = "22-05-2007"
                Workbooks.Item(1).Sheets.Item(sheetnr).Range("D" & rowNumber) = "Ja"
                Workbooks.Item(1).Sheets.Item(sheetnr).Range("E" & rowNumber) = "Verhoogd"
                Workbooks.Item(1).Sheets.Item(sheetnr).Range("F" & rowNumber) = "Ja"
                Workbooks.Item(1).Sheets.Item(sheetnr).Range("G" & rowNumber) = "Ja"
                Workbooks.Item(1).Sheets.Item(sheetnr).Range("H" & rowNumber) = "yes"
                Workbooks.Item(1).Sheets.Item(sheetnr).Range("I" & rowNumber) = "Knopjesnaam"
                
                Workbooks.Item(1).Sheets.Item(sheetnr).Range("A" & (rowNumber - 1)) = ""
                Workbooks.Item(1).Sheets.Item(sheetnr).Range("B" & (rowNumber - 1)) = "Is check uitgevoerd?"
                Workbooks.Item(1).Sheets.Item(sheetnr).Range("C" & (rowNumber - 1)) = "Datum check"
                Workbooks.Item(1).Sheets.Item(sheetnr).Range("D" & (rowNumber - 1)) = "Was de role positief?"
                Workbooks.Item(1).Sheets.Item(sheetnr).Range("E" & (rowNumber - 1)) = "Welk risico is aanwezig?"
                Workbooks.Item(1).Sheets.Item(sheetnr).Range("F" & (rowNumber - 1)) = "Is het risico afgetekend?"
                Workbooks.Item(1).Sheets.Item(sheetnr).Range("G" & (rowNumber - 1)) = "Gaat U accord met onderstaande gegevens?"
                Workbooks.Item(1).Sheets.Item(sheetnr).Range("H" & (rowNumber - 1)) = "Uitgevoerd volgens Protocol?"
                Workbooks.Item(1).Sheets.Item(sheetnr).Range("I" & (rowNumber - 1)) = "Button"
            Set rowNumber = .FindNext(rowNumber)
        Loop While Not rowNumber Is Nothing And rowNumber <> firstAddress
    End If
End With

   sheetnr = sheetnr + 1
    Loop
    
End Sub

 

[Wigi]

Als je er een representatief voorbeeldbestandje bij doet, kijk ik er zeker vandaag of één van de volgende dagen naar.

 

[HansolD]

Dat zou fijn zijn.
Ik hoop dat ik het script nu wat duidelijker heb gemaakt. Het bestandje zit in de bijlage.

Groeten, Hansol

 

[Wigi]

Kopiëren en plakken in een tekstbestandje lukt mij ook nog wel

Maar kan je je bestand niet bijvoegen, of een stuk daaruit?

 

[HansolD]

Sorry dan begreep ik het verkeerd. Ik kan helaas het bestand zelf niet toevoegen maar wel een die voldoet voor testen.

 

[Wigi]

Alsjeblieft.

Sub macro()

'==========================================
'VUL ZOEKTERM IN
    Const searchStr As String = "wret"
    '==========================================

    Dim rowNumber As Long
    Dim wsBlad As Worksheet
    Dim sheetnr As Integer
    Dim rFound As Range
    Dim lastRow As Long
    Dim strRowNoList As String

    For Each wsBlad In ThisWorkbook.Worksheets

        With wsBlad.Columns(1)

            On Error Resume Next
            Set rFound = .Find(searchStr, LookIn:=xlValues, lookat:=xlWhole)
            On Error GoTo 0

            If Not rFound Is Nothing Then

                firstAddress = rFound.Address

                Do

                    rFound.Resize(1, 9).Value = Array(searchStr, _
                                                      "Ja", _
                                                      "22-05-2007", _
                                                      "Ja", _
                                                      "Verhoogd", _
                                                      "Ja", _
                                                      "Ja", _
                                                      "yes", _
                                                      "Knopjesnaam")

                    rFound.Offset(-1).Resize(1, 9).Value = Array("", _
                                                                 "Is check uitgevoerd?", _
                                                                 "Datum check", _
                                                                 "Was de role positief?", _
                                                                 "Welk risico is aanwezig?", _
                                                                 "Is het risico afgetekend?", _
                                                                 "Gaat U accord met onderstaande gegevens?", _
                                                                 "Uitgevoerd volgens Protocol?", _
                                                                 "Button")

                    Set rFound = .FindNext(rFound)

                Loop While rFound.Address <> firstAddress

            End If

        End With

    Next

End Sub

Wigi

 

[HansolD]

Dankjewel Wigi, hij werkt als een zonnetje.
Je bent mijn held. :thumb: