Nummernzuordnung

[Jackie20004]

Hallo zusammen,
ich bin neu hier und verzweifelt, da ich mit meinem Problem nicht mehr weiter komme...ich möchte gerne folgendes tun und zwar immer den Namen an die "1" verschieben. Das funktioniert zwar jetzt schon mit dem Makro, aber in der falschen Spalte, denn das sollte in Spalte A alles bleiben und nicht in die Spalte E verschieben, dennoch dynamisch sein...egal in welcher Zelle in Spalte A ich es dann starte. Ich habe mal ein Beispiel angefügt wie ich es meine und auch mal das Makro. Da meine Kenntnisse sehr dürftig sind muss ich wohl öfters nachfragen .

Vielen Dank für eure Hilfe
LG Jackie

Code:

Sub los()
Dim Zelle As Range
Dim i As Long
For Each Zelle In Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns("D"))
   If Zelle = 1 Then
       i = i + 1
       Zelle.Offset(0, 1) = ActiveSheet.Cells(i, "A")
   End If
Next Zelle
End Sub

[MisterBurns]

Hallo Jackie,

schreib statt

Code:

Zelle.Offset(0, 1) = ActiveSheet.Cells(i, "A")

einfach

Code:

Zelle.Offset(0, -3) = ActiveSheet.Cells(i, "A")

denn du möchtest ja von der Ausgangszelle (in Spalte D) um 3 Spalten nach links gehen. Mit Offset(0, 1) gehst du um eine Spalte nach rechts.

Und mit

Code:

ActiveSheet.Cells.ClearContents

löschst du den Namen gleichzeitig von oben weg.

[Jackie20004]

Hallo Berni,
das werde ich mal ausprobieren...
LG Jackie

---

Das hat schon mal funktioniert, aber wenn ich

Code:

ActiveSheet.Cells.ClearContents

eingebe dann ist alles weg   was habe ich da falsch gemacht?

[Gast 123]

Hallo

du hast NICHTS falsch gemacht, sondern schlicht und einfach im Code von Berni einen eklatanter Fehler NICHT gesehen, wie er jedem Ratgeber unabsichtlich passieren kann! Schau ihn dir bitte genau an, dann lernst und verstehst du selbst die Befehls Sprache von VBA.
ActiveSheet.Cells.ClearContents

ActiveSheet erklaert sich von selbst, das aktive Blatt. ClearContents erklart sich auch von selbst: "Lösche den Inhalt" im angegebenen Bereich.  Cells bezieht sich auf das ganze Blatt, auf alle Zellen!  Muss ich weiter erklaeren, oder kombinierst du selbst was nach dem Makro Start dann PASSİERT?!!  Der Code tut nur das was er soll!  

Ich rate dringend davon ab die Namen in Spalte A aufzulisten, denn wenn die Liste zu lang ist überschreibst du dir selbst dort die Namen wo eine "1" steht!! Das ist nicht sinnvoll!  Die Liste löschen kannst du so:

mfg  Gast 123

Code:

Sub los()
Dim Zelle As Range
Dim i As Long
For Each Zelle In Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns("D"))
   If Zelle = 1 Then
       i = i + 1
       Zelle.Offset(0, -3) = ActiveSheet.Cells(i, "A")
   End If
Next Zelle
'Spalte A löschen
ActiveSheet.Range("A2").Resize(i - 1, 1).ClearContents
End Sub

[Käpt'n Blaubär]

Hallo Gast,

ActiveSheet.Cells.ClearContents

oh weh, ... das habe ich auch, trotz Nasenfahrrad, übersehen. Peinlich,  ... peinlich, ... peinlich.

[snb]

Die Namen in F1:F5

In A1:

PHP-Code:

=IFERROR(INDEX($F$1:$F$5;COUNTIF($D$1:$D1;1)/(D1=1));"") 


Durchziehen bis A40

[MisterBurns]

Uiuiui, Asche auf mein Haupt!

[Jackie20004]

Stimmt, danke für den Hinweis. Leider hat sich mit dem Code ein neues Problem aufgetan, ich muss nämlich bei der zweiten Liste die Positionen verändern - und somit funktioniert der Code dann nicht mehr.
Es muss ab Zeile 8 beginnen, demnach kann er es jetzt so nicht mehr. Könntet ihr bitte hier nochmal nachschauen??

[snb]

Schau mal: https://www.clever-excel-forum.de/Thread...#pid165281

[Gast 123]

Hallo

ich habe mir erlaubt den Code mal zu aendern, als Lösung eine alte Rückwaerts Variante genommen. 
Sie hat den Vorteil das man sich keine Daten überschreibt. Der Code ist auch für Anfanger leicht zu verstehen.

mfg  Gast 123

Code:

Sub Start_Gast()
Dim lz1 As Long, i As Long
Dim lz4 As Long, n As Long
'LastCell in Spalte A + D ermitteln
lz1 = Cells(Rows.Count, 1).End(xlUp).Row
lz4 = Cells(Rows.Count, 4).End(xlUp).Row

'Rückwarts ausfüllen mit Step-1
For i = lz4 To 8 Step -1
  If Cells(i, 4) = 1 Then
     Cells(lz1, 1).Resize(1, 3).Cut Cells(i, 1)
     lz1 = lz1 - 1
     If lz1 = 8 Then Exit For
  End If
Next i
End Sub