Dubbele For-Next lus

[wieter]

In de code achter een knop, heb ik een dubbele For Next - lus.
Die doet echter niet wat ik wil.
Waarschijnlijk heb ik de instructies op de verkeerde plaats staan in de code.

Sub Opvragen_Wijzigen()
Application.ScreenUpdating = False
ID = Sheets(1).Cells(3, 6).Value
With Sheets(2)
    WorksheetFunction.Index(.Columns(1), WorksheetFunction.Match(ID, .Columns(1))) = Sheets(1).Cells(3, 6).Value
    For x = 5 To 9
    For y = 2 To 6
    If Sheets(1).Cells(x, 7) = "" Then
    WorksheetFunction.Index(.Columns(y), WorksheetFunction.Match(ID, .Columns(1))) = Sheets(1).Cells(x, 6).Value
    Else
    WorksheetFunction.Index(.Columns(y), WorksheetFunction.Match(ID, .Columns(1))) = Sheets(1).Cells(x, 7).Value
    End If
    Next y
    Next x
End With
Sheets("Blad1").Range("G5:G9").ClearContents
Application.ScreenUpdating = True
End Sub

In de bijlage wordt de fout duidelijk.
Wie biedt hulp?

ps. Ter verduidelijking in de tweede bijlage, hetzelfde bestand, met de lange code.(werkt wel)

 

[Warme bakkertje]

Sub Nieuwe_invoer()
    Application.ScreenUpdating = False
    With Sheets(1)
        arr = Array(.Cells(3, 3).Value, .Cells(5, 3).Value, .Cells(6, 3).Value, .Cells(7, 3).Value, _
            .Cells(8, 3).Value, .Cells(9, 3).Value)
        .Range("c5:c9").ClearContents
    End With
    With Sheets(2)
        .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 6) = arr
        With .Columns
            .AutoFit
            .HorizontalAlignment = xlCenter
        End With
    End With
    Application.ScreenUpdating = True
End Sub
Sub Opvragen_Wijzigen()
    Application.ScreenUpdating = False
    ID = Sheets(1).Cells(3, 6).Value
    With Sheets(2)
        fRow = Application.Match(ID, .Columns(1), 0)
        For x = 5 To 9
            If Sheets(1).Cells(x, 7) <> vbNullString Then
                .Cells(fRow, x - 3) = Sheets(1).Cells(x, 7).Value
            End If
        Next x
    End With
    Sheets("Blad1").Range("G5:G9").ClearContents
    Application.ScreenUpdating = True
End Sub

 

[wieter]

Knap Rudi,
Nu uw code nog tegoei uitpluizen.
Hartelijk bedankt!

 

[VenA]

Een andere optie om het helemaal dmv VBA af te handelen.

Een Change event in blad1

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) = "F3" Then
    id = Sheets(2).Columns(1).Find(Target).Row
    [F5:F9] = Application.Transpose(Sheets(2).Cells(id, 1).Offset(, 1).Resize(, 5))
End If
End Sub

In een module

Public id
Sub Nieuwe_invoer()
If Application.CountA([C5:C9]) > 0 Then
    With Sheets(2)
        lr = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        .Cells(lr, 1) = [C3]
        .Cells(lr, 2).Resize(, 5) = Application.Transpose([C5:C9])
        [C3] = Application.Max(.Columns(1)) + 1
    End With
    [C5:C9].ClearContents
End If
End Sub
Sub Opvragen_Wijzigen()
For j = 5 To 10
    If Cells(j, 7) = "" Then c00 = c00 & "|" & Cells(j, 6) Else c00 = c00 & "|" & Cells(j, 7)
Next j
If c00 <> "" Then
    Sheets(2).Cells(id, 2).Resize(, 5) = Split(Mid(c00, 2), "|")
    [F5:F9] = Application.Transpose(Sheets(2).Cells(id, 1).Offset(, 1).Resize(, 5))
    [G5:G9].ClearContents
End If
End Sub

Met een Activate event voor blad2

Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
With UsedRange
    .Columns.AutoFit
    .Cells.HorizontalAlignment = xlCenter
End With
End Sub

 

[wieter]

Ma how seg!!!!
Super VenA, nu kan ik die kolom voor de wijzigingen ook wegwerken.
De wijzigingen kunnen nu rechtstreeks in de opgevraagde gegevens uitgevoerd worden.

De codes van de specialisten kan ik meestal lezen en begrijpen.
Maar de logica in een routine zelf opbouwen is voor mij nog een stap te ver.
Dank zij de inbreng van de specialisten vorder ik langzaam.

Nogmaals dank aan VenA en Rudi:thumb: