Indsæt celler ved siden af unikke værdier

Hvor mange produktnavne er der tale om?

Kunne man forestille sig at de bestående data gemmes og indsættes igen automatisk via VBA.

Hej Supertekst

Der er tale om ca. 200 navne.

Ok - vil det så sige, at når der opdateres, så vises kun navnene.
Kunne "gamle" data gemmes på et andet ark i filen - eller?

Hej Igen

Ved ikke om løsningen med at gemme er nogen gode ide, da produkterne skal gemmes i den rækkefølge de står i fra det oprindelige ark.
I det oprindelige ark kan der tilføjes produkter midt i listen, såvel som i toppen eller bunden. (de står i bestemt rækkefølge)

Tænker at indeksformlen måske er en dårlig løsning, VBA er måske den bedste løsning?

Har du mulighed for at uploade/sende en model, der vises data før og efter opdateringen?
@-adresse under min profil, hvis mail vælges.

Mail sendt! :-)

Rem VERSION 2 04-09-2015
Rem ====================
Rem aktiviteter
Const ræk1 = 4
Const rækX = 34
Const kol1 = 3  '"C"
Const kolX = 47 '"AU"
Const kolDiff = 4

Dim ptVærdi As String, nyVærdi As String

Rem prisListe
Dim sidsteRæk As Integer, flag As Boolean
Const totalSUM = "=Sum(B5:C"
Private Sub Worksheet_Activate()
    flag = False
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    flag = True
    Target = ""
    Cancel = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    If flag = False And testCelleAdresseOk(Target, Target.Column, Target.Row) = True Then
        nyVærdi = Target
        sidsteRæk = findSidsteRække
       
    Rem er det en sletning
        If nyVærdi = "" Then
            sletRække ptVærdi
        Else
    Rem ny aktivitet
            If nyVærdi <> "" Then
                indsætRække nyVærdi
            End If
        End If
       
        ActiveWorkbook.Save
        sidsteRæk = findSidsteRække
        ActiveSheet.Range("C2").Formula = totalSUM & CStr(sidsteRæk) & ")"
       
        ActiveWorkbook.Sheets("Aktiviteter").Activate
    End If
   
    flag = False
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ptVærdi = Target
End Sub
Private Function findSidsteRække()
    ActiveWorkbook.Sheets("Aktiviteter prisliste").Activate
    findSidsteRække = ActiveCell.SpecialCells(xlLastCell).Row
End Function
Private Sub sletRække(aktNr)
Dim ræk
    For ræk = 5 To sidsteRæk
        If ActiveSheet.Range("A" & ræk).Text = aktNr Then
            ActiveSheet.Rows(ræk & ":" & ræk).Select
            Selection.Delete
            Exit Sub
        End If
    Next ræk
End Sub
Private Sub indsætRække(aktNr)
Dim ræk As Integer, ptAkt, nyAkt
    flag = True
   
    nyAkt = Int(Left(aktNr, 4))
    For ræk = 5 To sidsteRæk
        If ActiveSheet.Range("A" & ræk) <> "" Then
            ptAkt = Int(Left(ActiveSheet.Range("A" & ræk), 4))
           
Rem Check om aktivitetsnr findes i forvejen - hvis ja - skip
            If nyAkt = ptAkt Then
                Exit Sub
            End If
           
            If nyAkt < ptAkt Then
                ActiveSheet.Rows(ræk).Select
                Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
                ActiveSheet.Range("A" & ræk) = aktNr
                Exit Sub
            End If
        End If
    Next ræk
   
    ActiveSheet.Range("A" & sidsteRæk + 1) = aktNr
End Sub
Private Function testCelleAdresseOk(værdi, kolonne, række)
Dim ræk As Integer, venstreHerfor
    If InStr(adresse, ":") > 0 Then
        testCelleAdresseOk = False
    Else
        If række >= ræk1 And række <= rækX And kolonne >= kol1 And kolonne <= kolX Then
            venstreHerfor = Cells(række, kolonne).Offset(0, -1)
            If IsNumeric(venstreHerfor) = True And venstreHerfor <> "" Then
                testCelleAdresseOk = True
            Else
                testCelleAdresseOk = False
            End If
        Else
            testCelleAdresseOk = False
        End If
    End If
   
    If testCelleAdresseOk = False Then
        MsgBox "AktivitetsNr. " & værdi & " ikke registreret korrekt"
    End If
End Function