Office: (Office 2013) Überschrift kopieren per VBA?

Hallo Forum, ich bin neu hier und habe ein Frage bzw. bitte um Hilfe:

Ich muss aus einem Tabellenblatt einzelne Zeile (je nach Wert) in ein neues kopieren, das erledige ich mit einem Makro, das ich hier gefunden habe.
Es funktioniert genausso wie ich es brauche, allerdings kopiert er mir die Überschrift aus dem Quellblatt (ist immer A3:N3)nicht mit. Kann mir hier jemand bitte helfen, vielen Dank
Hier das verwendete VBA.

Sub Makro3A()
Dim rng As Range
Dim Suchbegriff As String
Dim Antwort As String
Dim wksOrig As Worksheet
Dim rngNeueZelle As Range

' Auschalten der Bildschirmaktualisierung
Application.ScreenUpdating = False

' Abfrage des Suchwortes in der aktuellen Tabelle
Suchbegriff = InputBox("Bitte geben Sie den Suchbegriff eingeben:")

' Wenn kein Suchbegriff eingegeben wurde = Fehlermeldung
If Suchbegriff = "" Then
Beep
MsgBox "Ohne Begriff kann ich nicht suchen :-)!", , Application.UserName
Exit Sub
End If

' Suchroutine
Set rng = Cells.Find(what:=Suchbegriff, LookAt:=xlWhole, LookIn:=xlValues, SearchOrder:=xlByRows, _
MatchCase:=True, After:=Range("A1"))

' Wenn Suchbegriff nicht in Tabelle = Fehlermeldung
If rng Is Nothing Then
Beep
MsgBox "Der Suchbegriff wurde nicht gefunden, es gibt nichts zu tun!", , Application.UserName
Exit Sub
End If

' Suchbegriff inklusive der kompletten Zeile kopieren und in neue Tabelle mit Namen des Suchbegriffs einfügen
Set wksOrig = ActiveSheet
Antwort = rng.Address
Rows(rng.Row).Copy
Sheets.Add
ActiveSheet.Name = Suchbegriff
Set rngNeueZelle = Sheets(Suchbegriff).Range("A1")
rngNeueZelle.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Rows(rngNeueZelle.Row).Insert Shift:=xlDown

' Weitersuchen in der aktiven Tabelle nach dem Suchbegriff und wenn gefunden, in Tabelle mit Namen Suchbegriff einfügen
wksOrig.Activate
Cells.FindNext(After:=rng).Activate
While ActiveCell.Address rng.Address
Rows(ActiveCell.Row).Copy
Sheets(Suchbegriff).Activate
Rows("1:1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Rows("1:1").Insert Shift:=xlDown
wksOrig.Activate
Cells.FindNext(After:=ActiveCell).Activate

Wend
' Einschalten der Bildschirmaktualisierung
Application.ScreenUpdating = True
End Sub

:)

 

Halle
Habe die erforderlichen Code-Zeilen ergänzt.
Hiermit sollte es nun klappen:

Code:

Gruss,

Tinker Bell

 

Hallo Tinker Bell,
erst mal vielen herzlichen Dank für deine Hilfe, allerdings nimmt er die Überschriften nicht mit? Das kopieren der Zellen nach "Schlagwort" funktioniert sauber! nur eben ohne die Überschrift?
Eine weitere Frage wäre bitte: wie kann man es einstellen das über ALLE Tabellenblätter gesucht wird und nicht nur über die "Active"?
Vielen Dank
Grüße
Peter

 

Hallo
Was meinst du mit:

Deine Ueberschrift steht in A3:N3. und dieser Bereich wird ins neue Blatt kopiert.

Du kannst mit folgender Schlaufe alle Arbeitsblätter durchlaufen lassen:
Code:

Gruss,

Tinker Bell

 

Hallo,
also irgendwie stell ich mich zu blöd an *upps
Ich stell dir mal die Excel rein, er soll nach z.B.: "Schwer" suchen und dann alle Zeilen in ein neues Blatt "Schwer" kopieren, egal auf welchen Tabellenblatt die sind und es soll die Überschrift mit aber irgendwie bekomm ich das nicht hin *rolleyes.gif* .. wo muss dein oberer Code rein, damit er alle Tabellenblätter durchläuft? Danke

 

Hallo
Ich werde in deine Mappe schauen und dir die Folder Suche einbinden.

Gruss,

Tinker Bell

 

Hallo
Ich habe dir den Code entsprechend angepasst.
Die Ueberschrift wird nun kopiert.
Es hat nicht funktioniert weil ich von einer verbundenen Zelle ausging.

Dies zeigt mal wieder, eine Beispieldatei sagt mehr als tausend Worte.

Weiter wird nun in allen Tabellensheets nach dem Suchwort gesucht. Nur sind deine Tabellensheets unterschiedlich aufgebaut was die Spaltenüberschriften angeht.

Gruss,

Tinker Bell

 

Guten Morgen,
vielen Dank für deine Hilfe, ist das Makro bei dir gelaufen? ich bekomme nur Fehler siehe Anhang?
Danke Grüße

Peter

 

Hallo
Ich habe die Datei nochmals geprüft. Bei mir läuft das Makro ohne Fehler durch.
Ich verwende Windows 7 mit Excel 2007

Gruss,
Tinker Bell

 

Hallo,
WIN 7 mit Excel 2013, er bleibt immer an derseben Stelle hängen? Ich suche nach "Schwer" und dann kommt der Fehler?
Danke
Peter

 

Hallo
Hast du meine zuletzt hochgeladene Datei auch versucht?
Habe dort die Art des Worksheets ansprechens geändert:

Gruss,

Tinker Bell

 

Ja, da kommt dann der Fehler:
'Zellenformatierung anpassen
For I = 1 To 14
Set rngSpalte = Worksheets(Suchbegriff).Columns.Item(I)
rngSpalte.ColumnWidth = arrBreite(I)
Next I

 

Hallo
Dann setzte diesen Abschnitt auf Kommentar, und teste ob er dann durchläuft.
Anschliessend kannst du dann mittels Makro-Recorder ermitteln wie die Zellenbreite in Excel 2013 angepasst wird.

Gruss,

Tinker Bell

 

Ja, Danke das hat funktioniert, die "formatierung" ist auch nicht so wichtig, bei meiner Originalen läuft er nun aber auf einen anderen Fehler!
--> Laufzeitfehler 91
'Set wksOrig = ActiveSheet
Antwort = rng.Address
Rows(rng.Row).Copy
Sheets(Suchbegriff).Activate

Rest läfut nun sauber durch

 

Hallo
Was steht den in der Variable rng.Adresse? Ist der Inhalt korrekt?

Gruss,

Tinker Bell