Suchen und Einfügen

Tim · 2018-11-13T19:57:17+00:00

Hallo zusammen, ich benötige Hilfe bei einem bestimmten Macro. Man soll in Tabellenblatt 1 ein Suchwort eingeben können, anschließend soll dieses in Tabellenblättern 2 bis 4 in der ersten Spalte gesucht werden. Wird ein Eintrag gefunden, so soll entsprechend die gesamte Zeile in Tabellenblatt 1 eingefügt werden. Wäre super, wenn mir jemand behilflich sein könnte. Liebe Grüße Tim

Hallo Tim,
teste mal:

Option Explicit
Public Sub Suchen_kopieren()
Dim ws As Worksheet, loLetzte As Long, loLetzteZ As Long
Dim strSuche As String
strSuche = Worksheets("kombination").Range("B2")
If strSuche = vbNullString Then
MsgBox "Sie haben keinen Suchbegriff eingegeben."
Exit Sub
End If
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
Select Case ws.Name
Case "2000E", "4000F", "8000H"
With ws
If WorksheetFunction.CountIf(.Columns(1), strSuche) > 0 Then
.UsedRange.AutoFilter Field:=1, Criteria1:=strSuche
loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row
.AutoFilter.Range.Offset(1).Resize(.AutoFilter.Range.Rows.Count - 1).Copy
With Worksheets("kombination")
loLetzteZ = .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Row
.Cells(loLetzteZ, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End With
.AutoFilterMode = False
End If
End With
Case Else
'nix machen
End Select
Next ws
End Sub

Gruß Werner

Hallo Tim,
nimm den Code. Im anderen hatte ich noch eine überflüssige Variable und eine überflüssige Codezeile drin. Zudem habe ich hier jetzt noch ein Meldungsausgabe drin, sollte einmal der Suchbegriff in keinem der Blätter vorhanden sein.

Option Explicit
Public Sub Suchen_kopieren()
Dim ws As Worksheet, loLetzteZ As Long
Dim strSuche As String, boFund As Boolean
strSuche = Worksheets("kombination").Range("B2")
If strSuche = vbNullString Then
MsgBox "Sie haben keinen Suchbegriff eingegeben."
Exit Sub
End If
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
Select Case ws.Name
Case "2000E", "4000F", "8000H"
With ws
If WorksheetFunction.CountIf(.Columns(1), strSuche) > 0 Then
boFund = True
.UsedRange.AutoFilter Field:=1, Criteria1:=strSuche
.AutoFilter.Range.Offset(1).Resize(.AutoFilter.Range.Rows.Count - 1).Copy
With Worksheets("kombination")
loLetzteZ = .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Row
.Cells(loLetzteZ, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End With
.AutoFilterMode = False
End If
End With
Case Else
'nix machen
End Select
Next ws
If Not boFund Then
MsgBox "Der Suchbegriff " & strSuche & " ist in keinem der Blätter vorhanden."
End If
End Sub

Gruß Werner

Forumthread: Suchen und Einfügen

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Suchen und Einfügen

Forumthread: Suchen und Einfügen

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread