Texte löschen und transponieren - VBA

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Christian() Dim LR As Integer, Z1 As Integer, S1 As Integer, i As Integer Dim TMP As String, SP As Integer Z1 = 3 'erster Text in Zeile 3 S1 = 2 'Daten Spalte B SP = S1 + 1 'Zielspalte Application.ScreenUpdating = False With Sheets("Tabelle1") LR = .Cells(.Rows.Count, S1).End(xlUp).Row 'letzte Zeile der Spalte For i = Z1 To LR Step 4 TMP = .Cells(i, S1) If WorksheetFunction.CountIf(.Rows(1), TMP) = 0 Then .Cells(1, SP) = TMP SP = SP + 1 End If Next .Cells(1, S1).Resize(LR, 1).ClearContents End With End Sub

Hallo Uwe,
erst einmal danke für deine Mühe. Aber ich fürchte mir fehlen die VBA Kenntnisse um ihn so zu ändern, dass er dem entsprihcht was ich wollte.
Was zum Bsp. fehlt ist
1. dass es von alleine startet, sobald ich in Spalte B Texte einfüge
2. das es sich nicht auf B3 als Startzelle festlegt, sondern er auf alles reagiert, was ich in Spalte B einfüge, auch wenn die erste Zelle eine andere als B3 ist.
3. da gab es wohl ein Misverständnis, mit dem 3. 7. 11. 15. Text war der 3. 7. 11. 15. Text gemeint, den ich eingefügt hatte, nicht die Zellen B3, B7, B11, B15 usw., da ich ja an beliebigen Stellen in Spalte B einfügen möchte.
4. (ok, das ging nicht direkt aus der Bsp datei hervor, gebe ich zu), die transponierten Texte sollten in der ersten Zeile eingefügt werden, in die ich zuvor die Texte eingefügt habe. Dein Makro schreibt sie in Zeile 1.
Es tut mir leid, dass da jetzt so Umstände entstehen. Ich hate gedacht meine Bsp. Datei wäre eindeutig gewesen. Anscheinend fehlte mir das Excel Wissen um zu erkennen, wie man es sonst noch hätte deuten können.
Gruß
Christian

Hallo nochmal
dann versuch es so
Einmal
- Rechtsclick auf den Tabellenblattreiter
- Code anzeigen
- Den Code einfügen


Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Fehler
Const APPNAME = "Worksheet_Change"
Dim RNG As Range, TMP As String
Dim Z1 As Integer, Sp As Integer, i As Long
'Nur Spalte B berücksichtigen
Set RNG = Intersect(Columns(2), Target)
Z1 = 3 'StartZeile im Bereich
If Not RNG Is Nothing Then
If WorksheetFunction.CountBlank(RNG) = RNG.Count Then Exit Sub ' falls nur Leerzellen
Application.ScreenUpdating = False
Application.EnableEvents = False
For i = Z1 To RNG.Count Step 4
TMP = Target.Cells(i) 'der aktuelle Text
'Zählen, ob Text schon im Zielbereich vorhanden idt
If WorksheetFunction.CountIf(Target.Cells(1).Resize(1, Sp + 1), TMP) = 0 Then
'wenn neu, dann anfügen
Target.Cells(1).Offset(0, Sp) = TMP
Sp = Sp + 1
End If
Next
'Einfügebereich löschen, außer erste Zelle
RNG.Offset(1, 0).Resize(RNG.Count - 1).ClearContents
Application.EnableEvents = True
End If
'*** Fehlerbehandlung
Err.Clear
Fehler:
Application.EnableEvents = True
If Err.Number  0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
& "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub

Wenn du jetzt was in B einfügst, wird ab der ersten Zelle des Einfügebereichs abgearbeitet.
Auch beginnt das Ergebnis dann in der ersten Zelle.
LG UweD

Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo Fehler Const APPNAME = "Worksheet_Change" Dim RNG As Range, TMP As String, MMAx As Integer Dim Z0 As Integer, Z1 As Integer, Sp As Integer, i As Long 'Nur Spalte B berücksichtigen Set RNG = Intersect(Columns(2), Target) Z0 = 2 'Erster Durchlauf aus 2. Wert Z1 = 3 'StartZeile im Bereich MMAx = 132 If Not RNG Is Nothing Then If WorksheetFunction.CountBlank(RNG) = RNG.Count Then Exit Sub ' falls nur Leerzellen Application.ScreenUpdating = False Application.EnableEvents = False For i = Z0 To RNG.Count Step 4 TMP = Target.Cells(i) 'der aktuelle Text If i = Z0 Then i = Z0 - 3 ' von 2 auf 3 ändern 'Zählen, ob Text schon im Zielbereich vorhanden idt If WorksheetFunction.CountIf(Target.Cells(1).Resize(1, Sp + 1), TMP) = 0 Then 'wenn neu, dann anfügen Target.Cells(1).Offset(0, Sp) = TMP Sp = Sp + 1 End If Next 'Einfügebereich löschen, außer erste Zelle RNG.Offset(1, 0).Resize(RNG.Count - 1).ClearContents 'Leerzeile If RNG.Count > MMAx Then Rows(Target.Row + 1).Insert End If Application.EnableEvents = True End If '*** Fehlerbehandlung Err.Clear Fehler: Application.EnableEvents = True If Err.Number 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _ & "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear End Sub

Beliebteste Forumthreads (12 Monate)

Texte löschen und transponieren - VBA

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread