offset funktion will nicht wie ich

[Marie89]

Hey!

Folgendes Problem: Ich will, dass mein makro alle Zellen in der Spalte A überprüft, so bald irgendwo etwas doppelt vorkommt, soll die ganze zeile gelöscht werden, davor aber der inhalt aus Spalte C von den jeweiligen doppelten Zeilen (die dann gelöscht werden) 5 Spalten weiter rechts in eine einzige Zelle (die aus der Zeile, die nur einmal vorkommt) eingefügt wird.

N bisschen unverständlich geschrieben, aber ich weiss nich wie ichs sonst beschreiben soll, vielleicht hier nochmal was ich bis jetzt hab:

Sub DoppelteSätzeRauswerfen()

Dim CompareRange As Variant, x As Variant, y As Variant

Set CompareRange = Range("A1")

Dim Range1 As Variant, z As Variant

Set Range1 = Range("C1:C5")
Set z = Range1



For Each x In CompareRange
For Each y In CompareRange
For Each z In Range1
If x = y Then z.Offset(, 5) = z


Next z
Next y
Next x


Range("A1").Select
Do Until ActiveCell.Value = ""
If ActiveCell.Value = ActiveCell.Offset(1, 0).Value Then
ActiveCell.EntireRow.Delete
Else
ActiveCell.Offset(1, 0).Select
End If
Loop

End Sub



Vielen vielen Dank, wenn ihr mir irgendwie helfen könnt!!! lg Marie

[Severus]

Hi,
tut mir leid, aber das Ganze ist ein bißchen sehr wirr!

Du setzt CompareRange auf A1, versuchst aber später, A1, also eine einzelne Zelle zu durchsuchen.
Du setzt Range1 auf C1:C5 und dann setzt Du z auf Range1, anschließend benutzt Du z aber als Variable in einer For Each...Next Schleife. Und mit x und y durchsuchst Du eine einzelne Zelle A1, die Du als CompareRange gesetzt hast. Ich versuchs mal in der Hoffnung, daß ich Dich richtig verstanden habe:

Sub DoppelRaus
Dim CompareRange as Excel.Range
Dim Adresse As String
Dim Zelle As Excel.Range
Adresse = "$A$1:$A$" & CStr(Application.WorksheetFunction.CountA(Range("A:A")))
Set CompareRange = Range(Adresse)
For Each Zelle in CompareRange
  If Zelle.Offset(1, 0) = Zelle Then
    Zelle.Offset(0, 5) = Zelle.Offset(1, 2)
    Zelle.Offset(1, 0).EntireRow.Delete
  End If
Next

Set CompareRange = Nothing
End Sub

Severus

[Marie89]

danke

Vielen Dank für deine Hilfe... :-*
Ich weiss ich habs n bisschen wirr beschrieben, aber ich weiss nich wies genauer geht, vielleicht hier nochmal ein beispiel:

Spalte A
hallo
hallo
hallo
hallo
a
b
c
d
e

Spalte B

ich
bin
hier
im
haus
f
g
h
i
j

==> soll werden zu:

Spalte A (danach)

hallo
a
b
c
d
e

Spalte F (danach):

ich bin hier im haus
f
g
h
i
j


Dein makro funktioniert schon wesentlich besser wie meins, aber ich glaub ich habs dir einfach nicht gut genug beschrieben. Es sollen alle Zeilen gelöscht werden die doppelt oder dreifach oder vierfach sind (so wie des wort Hallo in Spalte A) und dann damit die Wörter aus Spalte B nicht verloren gehn alle in EINE neue Zelle aus Spalte F kopiert werden. Ich hoff du kannst mir noch weiter helfen... ich bin echt am verzweifeln ! Vielen Dank für deine Hilfe und die schnelle Antwort :-*

[Severus]

Option Explicit

Sub DoppelRaus()
Dim CompareRange As Excel.Range
Dim Adresse As String
Dim Zelle As Excel.Range
Dim Laufzahl As Long

UsedRange.Select
Selection.Sort key1:=Range("A1"), order1:=xlAscending, header:=xlYes 'oder xlNo wenn keine Kopfzeilen. Sortierung damit das Programm richtig ablaufen kann.

Adresse = "$A$1:$A$" & CStr(Application.WorksheetFunction.CountA(Range("A:A")))
Set CompareRange = Range(Adresse)
For Each Zelle In CompareRange
      If UCase(Zelle.Offset(1, 0)) = UCase(Zelle) Then
            Zelle.Offset(0, 5) = Zelle.Offset(0, 1)
            Laufzahl = 1
            Do
                  If UCase(Zelle.Offset(Laufzahl, 0)) <> UCase(Zelle) Then Exit Do
                  Zelle.Offset(0, 5) = Zelle.Offset(0, 5) & " " & Zelle.Offset(Laufzahl, 1)
                  Laufzahl = Laufzahl + 1
            Loop
            Range(Zelle.Offset(1, 0), Zelle.Offset(Laufzahl - 1, 0)).Select
            Selection.EntireRow.Delete
      End If
Next

Set CompareRange = Nothing
End Sub

Ich habs nochmal geändert, damit die Groß-/Kleinschreibung ignoriert wird.

[Marie89]

funktioniert super !

Danke... wieder für deine schnelle perfekte Hilfe !

Aber langsam blick ich nich mehr durch dein makro durch, ich glaub ich sollt doch nochmal nen kurs besuchen!

Funktioniert jetzt super für die eine excel tabelle die ich hab, du hast mir grad erspart 450 zeilen zu sortieren :-*

Jetz wollt ich des makro ändern (für eine andere excel tabelle) und zwar so, dass er nicht die Spalte A, sondern B auf wiederholungen untersucht (des hab ich noch hinbekommen ... so weit so gut... aber jetzt soll er nich die werte aus Spalte B nach rechts verschieben und zu einem Satz in einem Feld sortieren, sondern aus Spalte H und von da z.B. in Spalte I oder K wieder ausspucken in einem Satz und Feld.
Eigentlich müsste man des makro also so lassen und nur Spalte A auf Spalte B ändern und Spalte B auf Spalte H ändern, bloß wie schaff ich des ???

Ich hoff ich hab dich nicht zu sehr verwirrt... und kriegst mein eigentlich kleines problem wieder so schnell und perfekt hin !

lg Marie

[Severus]

Option Explicit

Sub DoppelRaus()
Dim CompareRange As Excel.Range
Dim Adresse As String
Dim Zelle As Excel.Range
Dim Laufzahl As Long

UsedRange.Select
Selection.Sort key1:=Range("B1"), order1:=xlAscending, header:=xlYes 'oder xlNo wenn keine Kopfzeilen. Sortierung damit das Programm richtig ablaufen kann.

Adresse = "$B$1:$B$" & CStr(Application.WorksheetFunction.CountA(Range("B:B")))
Set CompareRange = Range(Adresse)
For Each Zelle In CompareRange
      If UCase(Zelle.Offset(1, 0)) = UCase(Zelle) Then
            Zelle.Offset(0, 9) = Zelle.Offset(0, 6) 'Werte von H nach K
            Laufzahl = 1
            Do
                  If UCase(Zelle.Offset(Laufzahl, 0)) <> UCase(Zelle) Then Exit Do
                  Zelle.Offset(0, 9) = Zelle.Offset(0, 9) & " " & Zelle.Offset(Laufzahl, 6)
                  Laufzahl = Laufzahl + 1
            Loop
            Range(Zelle.Offset(1, 0), Zelle.Offset(Laufzahl - 1, 0)).Select
            Selection.EntireRow.Delete
      End If
Next

Set CompareRange = Nothing
End Sub

Severus

[Marie89]

variable nicht definiert

Danke wieder für deine schnelle antwort !

Jetzt kommt, wenn man des makro ausführt folgendes:

Fehler beim Kompilieren! Variable nicht definiert! ... und er markiert im makro die Zeile UsedRange.Select

Wo könnt da jetzt noch des Problem sein ?

Vielen vielen Dank für deine sehr gute Hilfe !

lg Marie

[Severus]

Vermutlich war das aktive Blatt keine Tabelle sondern z.B. ein Diagramm!

Ich habs jedenfalls nochmal verallgemeinert.

Option Explicit

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim CompareRange As Excel.Range
Dim Zelle As Excel.Range
Dim Laufzahl As Long
Dim SuchSpalte As Excel.Range, QuellSpalte As Excel.Range, ZielSpalte As Excel.Range
Dim SuchSpaltenNummer As Long, QuellSpaltenNummer As Long, ZielSpaltenNummer As Long
'Rechtsklick nur für A1 ausschalten
If Target.Address <> "$A$1" Then Exit Sub
On Error Resume Next
'Ereignisbearbeitung abschalten
Application.EnableEvents = False
With ActiveWorkbook
      With ActiveSheet
            If .Type = xlWorksheet Then
                  'Bereiche festlegen
                  Set SuchSpalte = Application.InputBox("Wählen Sie mit der Maus die Spalte mit den doppelten Werten aus:", "SuchSpalte", , , , , , 8)
                  If Err.Number = 424 Then GoTo LeerWert
                  SuchSpaltenNummer = SuchSpalte.Column
                  Set QuellSpalte = Application.InputBox("Wählen Sie mit der Maus die Spalte mit den Quelldaten aus:", "QuellSpalte", , , , , , 8)
                  If Err.Number = 424 Then GoTo LeerWert
                  QuellSpaltenNummer = QuellSpalte.Column
                  Set ZielSpalte = Application.InputBox("Wählen Sie mit der Maus die Spalte aus, in welche die Daten geschrieben werden sollen:", "ZielSpalte", , , , , , 8)
                  If Err.Number = 424 Then GoTo LeerWert
                  If ZielSpalte.Address = SuchSpalte.Address Then GoTo LeerWert
                  ZielSpaltenNummer = ZielSpalte.Column
                  'Bildschirmaktualisierung abschalten
                  Application.ScreenUpdating = False
                  'Sortieren
                  .UsedRange.Select
                  Selection.Sort key1:=SuchSpalte.EntireColumn.Cells(1, 1), order1:=xlAscending, header:=xlYes 'oder xlNo wenn keine Kopfzeilen. Sortierung damit das Programm richtig ablaufen kann.
                  'Suchbereich festlegen
                  Set CompareRange = .Range(SuchSpalte.EntireColumn.Cells(1, 1), SuchSpalte.EntireColumn.Cells(Application.WorksheetFunction.CountA(SuchSpalte.EntireColumn), 1))
                  'Mehrfacheinträge löschen
                  For Each Zelle In CompareRange
                        If UCase(Zelle.Offset(1, 0)) = UCase(Zelle) Then
                              Zelle.Offset(0, ZielSpaltenNummer - SuchSpaltenNummer) = Zelle.Offset(0, QuellSpaltenNummer - SuchSpaltenNummer) 'Werte von SuchSpalte nach ZielSpalte kopieren
                              Laufzahl = 1
                              Do
                                    If UCase(Zelle.Offset(Laufzahl, 0)) <> UCase(Zelle) Then Exit Do
                                    Zelle.Offset(0, ZielSpaltenNummer - SuchSpaltenNummer) = Zelle.Offset(0, ZielSpaltenNummer - SuchSpaltenNummer) & " " _
                                    & Zelle.Offset(Laufzahl, QuellSpaltenNummer - SuchSpaltenNummer)
                                    Laufzahl = Laufzahl + 1
                              Loop
                              .Range(Zelle.Offset(1, 0), Zelle.Offset(Laufzahl - 1, 0)).Select
                              Selection.EntireRow.Delete
                        End If
                  Next
                  'Verweise frreigeben
                  Set CompareRange = Nothing
                  Set SuchSpalte = Nothing
                  Set QuellSpalte = Nothing
                  Set ZielSpalte = Nothing
            Else
                  MsgBox "Aktives Blatt ist keine Tabelle!" & Chr(10) & "Das Programm wird abgebrochen.", vbCritical, "Fehler Arbeitsblatt..."
            End If
            .Range("A1").Select
      End With
End With
'Ereignisse und Bildschirmaktualisierung wieder einschalten
Application.EnableEvents = True
Application.ScreenUpdating = True
'Rechtsklick in A1 abschalten
Cancel = True
Exit Sub
LeerWert:
'Fehler bei der Bereichsauswahl bearbeiten
If SuchSpalte Is Nothing Then
      MsgBox "Keine SuchSpalte ausgewählt!" & Chr(10) & "Programm wird abgebrochen.", vbCritical, "Fehler Suchspalte..."
ElseIf QuellSpalte Is Nothing Then
      MsgBox "Keine QuellSpalte ausgewählt!" & Chr(10) & "Programm wird abgebrochen.", vbCritical, "Fehler Quellspalte..."
ElseIf ZielSpalte Is Nothing Then
      MsgBox "Keine ZielSpalte ausgewählt!" & Chr(10) & "Programm wird abgebrochen.", vbCritical, "Fehler Zielspalte..."
ElseIf ZielSpalte.Address = SuchSpalte.Address Then
      MsgBox "Ihre ZielSpalte ist identisch mit der SuchSpalte!" & Chr(10) & "Programm wird abgebrochen.", vbCritical, "Bereichskonflikt..."
End If
Err.Clear
Set SuchSpalte = Nothing
Set QuellSpalte = Nothing
Set ZielSpalte = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
Cancel = True
Exit Sub
Fehler:
'Andere Fehler abfangen
      MsgBox "Ein Fehler ist aufgetreten!" & Chr(10) _
      & "Fehlernummer:" & vbTab & " " & Err.Number & Chr(10) _
      & "Fehlerbeschreibung: " & Err.Description & Chr(10) _
      & "Fehlerquelle" & vbTab & " " & Err.Source & Chr(10) _
      & "Das Programm wurde abgebrochen.", vbCritical, "Abbruch..."
      Err.Clear
Set CompareRange = Nothing
Set SuchSpalte = Nothing
Set QuellSpalte = Nothing
Set ZielSpalte = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
Cancel = True
End Sub


End Sub

Severus

[Marie89]

Hut ab !!!

Vielen Vielen Dank für deine wahnsinns Hilfe... nicht schlecht :-*

Jetzt hast dus wirklich sehr allgemein gefasst! (so, dass es sogar ich verstehe )

Ich hoffe, wenn ich wieder mal ein problem kann ich mich an dich wenden... und dir vielleicht eine mail schreiben ?

lg Marie

[Severus]

Ubrigens kannst Du die Werte auch alle in die Quellspalte schreiben lassen. Du brauchst nur Quell und Zeilspalte identisch einzugeben. Der Erste Wert wird natürlich beibehalten. Außerdem kannst Du die Prozedur jetzt mit Rechtsklick auf A1 auslösen.



Severus

[Marie89]

Danke !!

stimmt... des funktioniert ja jetzt auch noch vielen vielen dank... du hast mir so viel arbeit erspart :-*

[Marie89]

Noch eine Frage!?

Eine Frage hätte ich noch: Woran liegt es, wenn des Makro von dir nicht überall angezeigt wird, also ich mein, man kann es nicht abspeichern und wenn man es ausführen will, ist es nirgends zu finden.
Liegt es an dem PrivateSub?

Lg Marie

[Severus]

Der Code muß im Klassenmodul des Arbeitsblattes abgelegt werden, in dem es ausgeführt werden soll. Also z.B. VBAProject (Name der Arbeitsmappe)-Tabelle1 (Tabelle1)
Außerdem die Sicherheitseinstellungen des jeweiligen Excel überprüfen.

Severus