Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
724to728
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
724to728
724to728
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Zelle kopieren

Zelle kopieren
25.01.2006 16:23:34
Rene
Moin zusammen,
Ich wollte gerne so eine Art Liste für Ortsnamen zum auswählen in Zelle "C3" haben.Wenn ich einen Namen in C3 eintrage soll eine Auswahliste der vorhanden Namen kommen oder neu eintragen.Nun habe ich dieses schon probiert:
Ich trage in "C3" einen Ortnamen ein nun wollte ich diesen nach "Y16" kopieren,(dieses ist ja klar :)),wenn ich nun in C3 einen neuen Namen eintrage soll dieser nach Y17 kopiert werden dieses immer so weiter.C3 kommt Ort rein nach Y18 kopieren usw.Wenn aber der Ort der in C3 steht schon in den Y Zellen vorkommt dann soll nichts kopiert werden.
Suche schon seit Tagen an einer Lösung komme aber nicht weiter, habe Gültigkeit,Liste erstellen,Filter ausprobiert aber ich komme nicht drauf.
Wie dieses per Macro gehen würde weis ich leider auch nicht.
Könnte mir da jemand weiter helfen? Wäre prima.
Gruß Rene

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Zelle kopieren
25.01.2006 16:46:04
Josef
Hallo Rene!
Kopiere den Code in das Modul der Tabelle!
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim varList() As Variant, lngRow As Long, lngFirst As Long, lngIndex As Long
Dim rng As Range
With Target
  If .Address = "$C$3" Then
    If .Value <> "" Then
      Set rng = Range("Y:Y").Find(What:=.Value, LookIn:=xlFormulas, LookAt:=xlWhole)
      If rng Is Nothing Then
        lngFirst = Cells(Rows.Count, 25).End(xlUp).Row + 1
        If lngFirst < 16 Then lngFirst = 16
        Cells(lngFirst, 25) = Target
        For lngRow = 16 To lngFirst
          If Len(Cells(lngRow, 25)) > 0 Then
            Redim Preserve varList(lngIndex)
            varList(lngIndex) = Cells(lngRow, 25).Text
            lngIndex = lngIndex + 1
          End If
        Next
        QuickSort varList
        If lngIndex > 0 Then
          With .Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
              xlBetween, Formula1:=Join(varList, ",")
            .ShowError = False
          End With
        End If
      End If
    End If
  End If
End With
Set rng = Nothing
End Sub

' Quicksort
'
Private Sub QuickSort(data() As Variant, Optional UG, Optional OG)
Dim P1&, P2&, T1 As Variant, T2 As Variant

UG = IIf(IsMissing(UG), LBound(data), UG)
OG = IIf(IsMissing(OG), UBound(data), OG)

P1 = UG
P2 = OG
T1 = data((P1 + P2) / 2)

Do
  
  Do While (data(P1) < T1)
    P1 = P1 + 1
  Loop
  
  Do While (data(P2) > T1)
    P2 = P2 - 1
  Loop
  
  If P1 <= P2 Then
    T2 = data(P1)
    data(P1) = data(P2)
    data(P2) = T2
    P1 = P1 + 1
    P2 = P2 - 1
  End If
  
Loop Until (P1 > P2)

If UG < P2 Then QuickSort data, UG, P2
If P1 < OG Then QuickSort data, P1, OG

End Sub


'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Anzeige
AW: Zelle kopieren
25.01.2006 17:36:18
Rene
Hi Sepp,
Ich danke dir wieder mal für deine Hilfe es klappt prima und ist genau das richtige.
:) :) :)
gruß Rene
Doch noch eine Frage
25.01.2006 18:47:29
Rene
Hallo Sepp,
Habe leider doch noch eine Frage die ich jetzt erst festgestellt habe.Ich wollte das Blatt schützen aber dann geht das Macro nicht mehr,hatte dieses leider vergessen mit anzugeben.Ich bekomme den LFZ Fehler "Die Methode "Add" für das Objekt Validation ist fehlgeschlagen".Ich hatte probiert am Anfang des Codes "ActiveSheet.Protect userinterfaceonly:=True" zu setzen aber es geht trotzdem nicht.Kannst du mir da mal noch mit bitte helfen?
Gruß Rene
Anzeige
AW: Doch noch eine Frage
25.01.2006 19:24:58
Josef
Hallo Rene!
Nimm diesen Code!
Eventuell musst du noch dein Passwort hinter Protect bzw. Unprotect setzen!
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim varList() As Variant, lngRow As Long, lngFirst As Long, lngIndex As Long
Dim rng As Range
On Error Resume Next
With Target
  If .Address = "$C$3" Then
    Me.Unprotect
    Application.EnableEvents = False
    If .Value <> "" Then
      Set rng = Range("Y:Y").Find(What:=.Value, LookIn:=xlFormulas, LookAt:=xlWhole)
      If rng Is Nothing Then
        lngFirst = Cells(Rows.Count, 25).End(xlUp).Row + 1
        If lngFirst < 16 Then lngFirst = 16
        Cells(lngFirst, 25) = Target
        For lngRow = 16 To lngFirst
          If Len(Cells(lngRow, 25)) > 0 Then
            Redim Preserve varList(lngIndex)
            varList(lngIndex) = Cells(lngRow, 25).Text
            lngIndex = lngIndex + 1
          End If
        Next
        QuickSort varList
        If lngIndex > 0 Then
          With .Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
              xlBetween, Formula1:=Join(varList, ",")
            .ShowError = False
          End With
        End If
      End If
    End If
    Application.EnableEvents = True
    Me.Protect
  End If
End With
Set rng = Nothing
End Sub


' Quicksort
'
Private Sub QuickSort(data() As Variant, Optional UG, Optional OG)
Dim P1&, P2&, T1 As Variant, T2 As Variant

UG = IIf(IsMissing(UG), LBound(data), UG)
OG = IIf(IsMissing(OG), UBound(data), OG)

P1 = UG
P2 = OG
T1 = data((P1 + P2) / 2)

Do
  
  Do While (data(P1) < T1)
    P1 = P1 + 1
  Loop
  
  Do While (data(P2) > T1)
    P2 = P2 - 1
  Loop
  
  If P1 <= P2 Then
    T2 = data(P1)
    data(P1) = data(P2)
    data(P2) = T2
    P1 = P1 + 1
    P2 = P2 - 1
  End If
  
Loop Until (P1 > P2)

If UG < P2 Then QuickSort data, UG, P2
If P1 < OG Then QuickSort data, P1, OG

End Sub


'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Anzeige
AW: Doch noch eine Frage
25.01.2006 21:14:13
Rene
Hi Sepp,
Danke es klappt.
Gruß Rene

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige