Kopieren , in Neues Blatt einfügen

Hey all,
Mein unten stehender Code geht soweit, bis auf das er mir nicht ab Zeile A2 sucht und dann im neuen Blatt bei A2 einfügt
Was muss ich da ändern ? Komm leider nicht drauf trotz auch nach langen suchen.


Private Sub CommandButton3_Click()
'    UserForm1.Hide
Dim ws As Worksheet, _
rErg As Range, _
strSearch As String, _
StrFirstFound As String, _
iFound As Integer
strSearch = InputBox("wonach wollen Sie suchen?", , "")
If strSearch = "" Then Exit Sub
On Error Resume Next           'ist das da richtig ?
Worksheets.Add Before:=Worksheets(1)   'wird ein Tabellenblatt ganz rechts erstellt
ActiveSheet.Name = "Gefunden"
'       Worksheets("Umsatz15").Rows(1).Copy Destination:= _
'       Worksheets("Gefunden").[a1]
Application.DisplayAlerts = True         ' steht das an richtiger Stelle ?
For Each ws In ThisWorkbook.Worksheets
If ws.Index > 1 Then
Set rErg = ws.Range("C:C").Find(strSearch)
If Not rErg Is Nothing Then
StrFirstFound = rErg.Address
Do
iFound = iFound + 1
'Ausgabe Fundzeile
rErg.EntireRow.Copy (ThisWorkbook.Worksheets(1).Cells(iFound, 1))
Set rErg = ws.Range("C:C").FindNext(rErg)
Loop While Not rErg Is Nothing And rErg.Address  StrFirstFound
End If
End If
Next ' ws
End Sub

Ich bin für jede Hilfe dankbar.
Mfg.
Dieter

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub t() Dim ws As Worksheet, _ rErg As Range, _ strSearch As String, _ StrFirstFound As String, _ iFound As Integer strSearch = InputBox("wonach wollen Sie suchen?", , "") If strSearch = "" Then Exit Sub Application.ScreenUpdating = False If Worksheets(1).Name "Gefunden" Then Worksheets.Add Before:=Worksheets(1) ActiveSheet.Name = "Gefunden" Else Worksheets(1).UsedRange.ClearContents End If For Each ws In ThisWorkbook.Worksheets If ws.Index > 1 Then Set rErg = ws.Range("A2:A" & Rows.Count).Find(strSearch) If Not rErg Is Nothing Then StrFirstFound = rErg.Address Do iFound = iFound + 1 rErg.EntireRow.Copy (ThisWorkbook.Worksheets(1).Cells(iFound, 1)) Set rErg = ws.Range("A2:A" & Rows.Count).FindNext(rErg) Loop While Not rErg Is Nothing And rErg.Address StrFirstFound End If End If Next ws End Sub

Sub t() Dim ws As Worksheet, _ rErg As Range, _ strSearch As String, _ StrFirstFound As String, _ iFound As Integer strSearch = InputBox("wonach wollen Sie suchen?", , "") If strSearch = "" Then Exit Sub Application.ScreenUpdating = False If Worksheets(1).Name "Gefunden" Then Worksheets.Add Before:=Worksheets(1) ActiveSheet.Name = "Gefunden" Range("A1") = "Titel" Else Worksheets(1).UsedRange.Offset(1, 0).ClearContents End If iFound = 1 For Each ws In ThisWorkbook.Worksheets If ws.Index > 1 Then Set rErg = ws.Range("A2:A" & Rows.Count).Find(strSearch) If Not rErg Is Nothing Then StrFirstFound = rErg.Address Do iFound = iFound + 1 rErg.EntireRow.Copy (ThisWorkbook.Worksheets(1).Cells(iFound, 1)) Set rErg = ws.Range("A2:A" & Rows.Count).FindNext(rErg) Loop While Not rErg Is Nothing And rErg.Address StrFirstFound End If End If Next ws End Sub

Sub t() Dim ws As Worksheet, _ rErg As Range, _ strSearch As String, _ StrFirstFound As String, _ iFound As Integer strSearch = InputBox("wonach wollen Sie suchen?", , "") If strSearch = "" Then Exit Sub Application.ScreenUpdating = False If Worksheets(1).Name "Gefunden" Then Worksheets.Add Before:=Worksheets(1) ActiveSheet.Name = "Gefunden" Range("A1") = "Titel" Else Worksheets(1).UsedRange.Offset(1, 0).ClearContents End If iFound = 1 For Each ws In ThisWorkbook.Worksheets If ws.Index > 1 Then Set rErg = ws.Range("C2:C" & Rows.Count).Find(strSearch) If Not rErg Is Nothing Then StrFirstFound = rErg.Address Do iFound = iFound + 1 rErg.EntireRow.Copy (ThisWorkbook.Worksheets(1).Cells(iFound, 1)) Set rErg = ws.Range("C2:C" & Rows.Count).FindNext(rErg) Loop While Not rErg Is Nothing And rErg.Address StrFirstFound End If End If Next ws End Sub

Sub t() Dim ws As Worksheet, _ rErg As Range, _ strSearch As String, _ StrFirstFound As String, _ iFound As Integer strSearch = InputBox("wonach wollen Sie suchen?", , "") If strSearch = "" Then Exit Sub Application.ScreenUpdating = False iFound = 1 For Each ws In ThisWorkbook.Worksheets If ws.Name "Gefunden" Then Set rErg = ws.Range("C2:C" & Rows.Count).Find(strSearch) If Not rErg Is Nothing Then StrFirstFound = rErg.Address Do If iFound = 1 Then If Worksheets(1).Name "Gefunden" Then Worksheets.Add Before:=Worksheets(1) ActiveSheet.Name = "Gefunden" Range("C1") = "Titel" Else Worksheets(1).UsedRange.Offset(1, 0).ClearContents End If End If iFound = iFound + 1 rErg.EntireRow.Copy (ThisWorkbook.Worksheets(1).Cells(iFound, 1)) Set rErg = ws.Range("C2:C" & Rows.Count).FindNext(rErg) Loop While Not rErg Is Nothing And rErg.Address StrFirstFound End If End If Next ws End Sub

Hi Dieter
Den anderen Beitrag habe ich erst jetzt gelesen bzw. überflogen:
https://www.herber.de/forum/archiv/1848to1852/1848688_Commandbutton_ansprechen.html
Daniel schreibt:
Ich würde dir empfehlen, einfach ein weiteres Blatt als Vorlage anzulegen, welches den Button und den Code enthält, und dann dieses Vorlagenblatt zu kopieren, anstatt ein neues Blatt zu erstellen.
Dieses Vorgehen würde auch ich dir empfehlen. Zumal das Blatt nicht einmal kopiert werden müsste sondern nur nach Bedarf ein-/ausgeblendet. Ausserdem willst du ja auch noch Titel (und womöglich andere Formatierungen) definieren, was sich deutlich einfacher verwirklichen und unterhalten lässt, wenn du einfach ein "Vorlageblatt" erstellst, anstelle in VBA zu programmieren.
Wenn nicht dieses Vorgehen, dann würde ich in dieser ganz speziellen Konstellation ebenfalls die Umgehungslösung mit dem DoubleClick-Event wählen. Nicht weil es benutzerfreundlicher wäre, sondern für diesen Spezialfall einfach leichter umzusetzen.
PS: Ich schlage vor, dass du mindestens einen der beiden Beiträge schliesst. Unglücklich wenn zwei Beiträge mit ähnlicher Fragestellung offen sind.
cu
Chris

Beliebteste Forumthreads (12 Monate)

Kopieren , in Neues Blatt einfügen

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

37 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Kopieren , in Neues Blatt einfügen

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

37 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread