Automatische gegevens overnemen

[call]

Wie kan mij helpen?
IK heb de volgende gegevens, in kolom A wordt items ingevuld en in kolommen B t/m M gegevens. Ik zou graag deze lijst automatiseren, zodat het volgende kan gebeuren:

Als ik bijv: in cel A3 item 2 typ moet B3:M3 automatisch de gegevens van cellen B2:M2 overnemen. En als ik vervolgens in A4 item 3 invul moet Excel automatisch de gegevens van rijen B3:M3 kopiëert naar B4:M4 enzovoorts. Dit geldt tot item 100.

Weet iemand hoe dit opgelost kan worden?

Alvast bedankt voor het meedenken

Groetjes

 

[OctaFish]

Dat kan zonder één regel programmeren...

 

[call]

Hay Michel, bedankt, maar dat is niet wat ik bedoel. De gegevens moeten in een blad zijn. Maar bedanken voor het meedenken.:thumb:

 

[Warme bakkertje]

Zet deze in de bladmodule van Sheet1

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
    Target.Offset(, 1).Resize(, 12) = Cells(Target, 2).Resize(, 12).Value
End If
End Sub

 

[Warme bakkertje]

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
    Target.Offset(, 10).Resize(, 3) = Cells(Target, 11).Resize(, 3).Value
End If
End Sub

 

[call]

Hoi Rudi,

Ik ben je heel erg dankbaar, voordat ik de vraag als opgelost zet, wil ik even vragen hoe ik deze fout melding kan oplossen:

Compile error:
Ambigous name deleted; worksheet change

 

[Warme bakkertje]

Beide macro's samenvoegen tot 1 macro omdat in elke bladmodule maar 1 keer dezelfde event-macro mag staan.

 

[call]

Ik krijg nog steeds dezelfde melding

 

[Warme bakkertje]

Post nog eens een voorbeeldbestandje met alles erin wat je tot hiertoe gedaan hebt.

 

[call]

Hierbij

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Column = 7 And Target.Offset(, 2).Value = "230x100x75cm" Then
    With Target.Offset(, 5)
        .Value = "Prijs in overleg"
   End With
   Exit Sub
Else
    On Error Resume Next
    If IsEmpty(Target.Offset(, 5).Validation.Type) Then
        With Target.Offset(, 5).Validation
            .Delete
            .Add xlValidateList, xlValidAlertStop, xlBetween, "=Lijst"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End With
    End If
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
    Target.Offset(, 1).Resize(, 12) = Cells(Target, 2).Resize(, 12).Value
End If
End Sub

 

[Warme bakkertje]

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Column = 1 Then
    With Target
        .Offset(, 1).Resize(, 12) = Cells(Target, 2).Resize(, 12).Value
        If .Offset(, 8).Value = "230x100x75cm" Then
            .Offset(, 11).Value = "Prijs in overleg": Exit Sub
        Else
        On Error Resume Next
        If IsEmpty(Target.Offset(, 11).Validation.Type) Then
            With Target.Offset(, 11).Validation
                .Delete
                .Add xlValidateList, xlValidAlertStop, xlBetween, "=Lijst"
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With
        End If
        End If
    End With
End If
End Sub

Test deze eens uit, het kan zijn dat je nog ergens de Offsets moet aanpassen maar bij gebrek aan een recent vb(zoals gevraagd) was het voor mij ook maar raden.

 

[call]

Nu krijg ik geen fout melding meer de macro doet het gewoon, alleen de eerst macro doet het niet meer. (dat als de afmeting 230x100x75cm melding geven: prijs in overleg)

 

[Warme bakkertje]

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Column = 1 Then
    Target.Offset(, 1).Resize(, 12) = Cells(Target, 2).Resize(, 12).Value
End If
If Target.Column = 7 And Target.Offset(, 2).Value = "230x100x75cm" Then
    With Target.Offset(, 5)
        .Value = "Prijs in overleg"
   End With
   Exit Sub
Else
    On Error Resume Next
    If IsEmpty(Target.Offset(, 5).Validation.Type) Then
        With Target.Offset(, 5).Validation
            .Delete
            .Add xlValidateList, xlValidAlertStop, xlBetween, "=Lijst"
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End With
    End If
End If
End Sub

 

[call]

:dIk weet het niet hoe ik je moet bedanken....maar Ik ben je heel erg dankbaar. Nu werken de 2 macro's vlekkeloos, gewoon perfect.:thumb::thumb: de laatste code heeft alles opgelost:d