|
Hallo Hans
Es tut mir leid, aber ich hatte echt viel zu tun.
Hier aber nun das fertige von mir mit der kleinen Tabelle geprüfte Makro.
Ich bin sicher, das irgendjemand kommen wird und dir erklärt das es mit Sicherheit noch einfacher geht, aber ich habe es mit den meinigen Fähigkeiten geschrieben und getestet.
Es ist weitestgehend erklärt und kann damit auch für einen Nichtexperten (wie Ich) angepasst werden.
Es besteht durchaus auch die Möglichkeit, wenn du eine Geringe Anzahl an Suchkriterien hast, diese mit einer Userform anzupassen.
Wenn du (wie ich dich oben Verstanden habe) mit einzelnen Buttons startest, kannst du ja einfach jedem Button ein eigenes Makro zuweisen, in dem du den Suchwert entsprechend dem Button änderst.
Wenn du noch andere Änderungen möchtest, sollte dies auch mögich sein.
Die Msgbox am Ende kannst du natürlich herausnehmen.
Ich hoffe ich habe das Makro gut Dokumentiert, damit es verständlich ist.
Hier nun das Makro:
Option Explicit
Sub AllesFinden()
Dim ErsterFund As String 'firstfound
Dim GefundeneZelle As Range 'foundcell
Dim rng As Range
Dim SuchBereich As Range 'myrange
Dim LetzteZelle As Range 'lastcell
Dim QName As Workbook 'Name der Quelldatei
Dim QWBSheet As Worksheet 'Name des WorkbookQuellsheet
Dim QSheet As String 'Name des Quellsheet als String
Dim ZSheet As String 'Name des neuen Zielsheet
Dim Suchwert As String 'find 'Nach was suchst du
Dim Zeile As Long 'Zeile in der etwas gefunden wurde
Dim LetzteZZeile As Long 'Letzte Zeile im Zielsheet
Dim Einfügezeile As Long 'Zeile nach der LetztenZeile zum Einfügen
Suchwert = "Waschmaschine" 'Oder eine Variable aus einer MSGBOX
Set QName = ActiveWorkbook 'Erstellt sich aus aktiver Quelldatei
Set QWBSheet = ActiveSheet 'Erstellt sich aus aktiven Quellsheet
QSheet = QWBSheet.Name
'Wenn du nur ein Neues Sheet einfügen möchtest:
With ThisWorkbook
.Sheets.Add after:=Sheets(Worksheets.Count)
.ActiveSheet.Name = "Waschmaschine"
' Alternativ: .ActiveSheet.Name = Suchwert
End With
ZSheet = ActiveSheet.Name 'Neuer Name des Zielsheet
'' Wenn du das Originalsheet umbenennen möchtest:
' Sheets(QWBSheet.Name).Select
' ActiveSheet.Name = "Original"
' QSheet = ActiveSheet.Name 'Neuer Name des Quellsheet
'Einfügen der 1. Zeile (Namen)
Worksheets(QWBSheet.Name).Activate
Range("1:1").Select
Selection.Copy
Worksheets(ZSheet).Activate
Range("1:1").Select
Selection.Insert
Worksheets(QSheet).Activate
Set SuchBereich = ActiveSheet.UsedRange
Set LetzteZelle = SuchBereich.Cells(SuchBereich.Cells.Count)
'Suche
Set GefundeneZelle = SuchBereich.Find(what:=Suchwert, after:=LetzteZelle)
If Not GefundeneZelle Is Nothing Then
ErsterFund = GefundeneZelle.Address
Zeile = GefundeneZelle.Row
Else: GoTo NothingFound
End If
Set rng = GefundeneZelle
Kopieren:
'Letzte Zeile im ZSheet feststellen (ändert sich nach jedem einfügen)
With Worksheets(ZSheet) ' Mit dem Ziellsheet
LetzteZZeile = IIf(IsEmpty(.Cells(Rows.Count, 2)), .Cells(Rows.Count, 2).End(xlUp).Row, Rows.Count) ' letzte volle Zeile in Ziel-Sheet Spalte 2=B ermitteln
End With
Einfügezeile = LetzteZZeile + 1
Worksheets(QSheet).Activate
Range(Zeile & ":" & Zeile).Select
Selection.Copy
Worksheets(ZSheet).Activate
Rows(Einfügezeile).Select
Selection.Insert
Do Until GefundeneZelle Is Nothing
Set GefundeneZelle = SuchBereich.FindNext(after:=GefundeneZelle)
If GefundeneZelle.Address = ErsterFund Then Exit Do
Zeile = GefundeneZelle.Row
'Kopieren im Loop
'Letzte Zeile im ZSheet feststellen (ändert sich nach jedem einfügen)
With Worksheets(ZSheet) ' Mit dem Ziellsheet
LetzteZZeile = IIf(IsEmpty(.Cells(Rows.Count, 2)), .Cells(Rows.Count, 2).End(xlUp).Row, Rows.Count) ' letzte volle Zeile in Ziel-Sheet Spalte 2=B ermitteln
End With
Einfügezeile = LetzteZZeile + 1
Worksheets(QSheet).Activate
Range(Zeile & ":" & Zeile).Select
Selection.Copy
Worksheets(ZSheet).Activate
Rows(Einfügezeile).Select
Selection.Insert
Loop
MsgBox ("Makro bendet")
Exit Sub
NothingFound:
MsgBox ("Nichts gefunden")
End Sub
|