flytte celle indhold til specifik celle !!!!!!!

HEj JEg prøver igen.

Jeg skal have reduceret et VBS script idet jeg tror det kan lade sig gøre og fordi jeg syntes det jeg har lavet er upraktisk(besværligt at udvide).

Jeg har en kolonne hvor jeg har noget alfanumerisk data stående i cellerne det kunne være erhverv eller bil mærker.

I en anden kolonne har jeg så nogle celler hvor indholdet af den først omtalte kolonne skal kopieres overi efter mit valg.

dvs. hvis jeg ønsker at indholdet af celle b6 skal kopieres over i celle e19 skriver jeg b6 f.eks. i celle f4 og e19 i celle f5. havde jeg skrevet b2 i celle f4 og e2 i f5 ville indholdet fra celle b2 kopieres i cele e2

denne handling kan laves med dette script

Private Sub makroknappen_Click()
        If Range("i5").Value = "a" Then
    Range("e3").Value = Range("j4").Value
    Range("I11,E6,E9,E12,E15,E18,E21,E24,E27,E30,J4").Select
        Selection.ClearContents
        Range("a1").Select
    ElseIf Range("i5").Value = "b" Then
    Range("e6").Value = Range("j4").Value
    Range("I11,E3,E9,E12,E15,E18,E21,E24,E27,E30,J4").Select
        Selection.ClearContents
        Range("a1").Select
    ElseIf Range("i5").Value = "c" Then
    Range("e9").Value = Range("j4").Value
    Range("I11,E3,E6,E12,E15,E18,E21,E24,E27,E30,J4").Select
        Selection.ClearContents
        Range("a1").Select
    ElseIf Range("i5").Value = "d" Then
    Range("e12").Value = Range("j4").Value
    Range("I11,E3,E6,E9,E15,E18,E21,E24,E27,E30,J4").Select
        Selection.ClearContents
        Range("a1").Select
    ElseIf Range("i5").Value = "e" Then
    Range("e15").Value = Range("j4").Value
    Range("I11,E3,E6,E9,E12,E18,E21,E24,E27,E30,J4").Select
        Selection.ClearContents
        Range("a1").Select
    ElseIf Range("i5").Value = "f" Then
    Range("e18").Value = Range("j4").Value
    Range("I11,E3,E6,E9,E12,E15,E21,E24,E27,E30,J4").Select
        Selection.ClearContents
        Range("a1").Select
    ElseIf Range("i5").Value = "g" Then
    Range("e21").Value = Range("j4").Value
    Range("I11,E3,E6,E9,E12,E15,E18,E24,E27,E30,J4").Select
        Selection.ClearContents
        Range("a1").Select
    ElseIf Range("i5").Value = "h" Then
    Range("e24").Value = Range("j4").Value
    Range("I11,E3,E6,E9,E12,E15,E18,E21,E27,E30,J4").Select
        Selection.ClearContents
        Range("a1").Select
    ElseIf Range("i5").Value = "i" Then
    Range("e27").Value = Range("j4").Value
    Range("I11,E3,E6,E9,E12,E15,E18,E21,E24,E30,J4").Select
        Selection.ClearContents
        Range("a1").Select
    ElseIf Range("i5").Value = "j" Then
    Range("e30").Value = Range("j4").Value
    Range("I11,E3,E6,E9,E12,E15,E18,E21,E24,E27,J4").Select
        Selection.ClearContents
        Range("a1").Select
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Range("i4").Value = "1" Then
    Range("j4") = Range("b3").Value
    ElseIf Range("i4").Value = "2" Then
    Range("j4") = Range("b6").Value
    ElseIf Range("i4").Value = "3" Then
    Range("j4") = Range("b9").Value
    ElseIf Range("i4").Value = "4" Then
    Range("j4") = Range("b12").Value
    ElseIf Range("i4").Value = "5" Then
    Range("j4") = Range("b15").Value
    ElseIf Range("i4").Value = "6" Then
    Range("j4") = Range("b18").Value
    ElseIf Range("i4").Value = "7" Then
    Range("j4") = Range("b21").Value
    ElseIf Range("i4").Value = "8" Then
    Range("j4") = Range("b24").Value
    ElseIf Range("i4").Value = "9" Then
    Range("j4") = Range("b27").Value
    ElseIf Range("i4").Value = "10" Then
    Range("j4") = Range("b30").Value
       
    End If
End Sub


Som i ser er det uoverkommeligt at udvide valgene.

dertil kommer også at jeg godt kunne tænke mig at der kom en dialogbox op hvis man skriver noget forkert eller henviser til en celle der ikke indeholder data.

Jeg sender gerne en kopi ar exel arket hvis der skulle være en der har interressen.

Mvh.

Thomas