Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1600to1604
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
String finden, Zeilen kopieren VBA
09.01.2018 18:04:22
Robert
Hallo Leute,
ich habe folgende Problem (siehe https://www.herber.de/bbs/user/118819.xlsm)
Ich habe zwei Reiter in einer Excel. Der zweite ("MA") beinhaltet Daten über Mitarbeiter (Spalten A:L).
Im zweiten Reiter "Übersicht" soll man in Zelle B1 ein Stichwort eingetragen können und per Knopfdruck ein VBA starten, was automatisch die Tabelle "MA" nach dem Stichwort durchsucht und sämtliche Zeilen in die Übersicht kopiert. Dabei ist es ein Problem, dass die Suchworte mehrfach vorkommen.
Mit meinen limitierten VBA Kenntnissen habe ich unten stehenden Code zustande gebracht. Dieser durchsucht allerdings nur einzelne Spalten.
Die Vorstellung wäre ein Code, der automatisch die gesamte Tabelle durchsucht, alle Zeilen kopiert und Duplikate automatisch entfernt.
Die letzten Stunden habe ich mich schon an der Erstellung eines Code mit der Range.Find Methode in Verbindung mit Copy and Paste versucht, bin aber gescheitert.
Ist hier jemand der mir diesbezüglich einen Tip geben könnte/ mich helfen könnte?
Danke im Voraus
VG
Robert
Sub Zeilekopieren()
Dim a As Long
Dim b As Long
Dim n As Long
With Sheet3
b = .UsedRange.Rows.Count
n = 1
For a = 2 To b
If InStr(.Cells(a, 5).Value, Sheet1.Cells(1, 2)) > 0 Then
.Rows(a).Copy Destination:=Sheet1.Rows(n + 3)
n = a + 1
End If
Next a
End With
End Sub
Private Sub CommandButton1_Click()
Worksheet("Übersicht").Range("A4:F250").ClearContents
Call Zeilekopieren
End Sub

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: String finden, Zeilen kopieren VBA
09.01.2018 18:29:54
Sepp
Hallo Robert,
' **********************************************************************
' Modul: Sheet1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Sub copyRows()
Dim rngFind As Range, rngCopy As Range
Dim lngRow As Long, lngRows() As Long
Dim varRet As Variant, strFirst As String, lngI As Long

Range("A4:L250").ClearContents
Redim lngRows(0)

With Sheets("MA")
  Set rngFind = .Range("A:L").Find(What:=Range("B1"), LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=False, Searchformat:=False)
  
  If Not rngFind Is Nothing Then
    strFirst = rngFind.Address
    Do
      varRet = Application.Match(rngFind.Row, lngRows, 0)
      If IsError(varRet) Then
        Redim Preserve lngRows(lngI)
        lngRows(lngI) = rngFind.Row
        lngI = lngI + 1
        If rngCopy Is Nothing Then
          Set rngCopy = .Range(.Cells(rngFind.Row, 1), .Cells(rngFind.Row, 12))
        Else
          Set rngCopy = Union(rngCopy, .Range(.Cells(rngFind.Row, 1), .Cells(rngFind.Row, 12)))
        End If
      End If
      Set rngFind = .Range("A:L").FindNext(rngFind)
    Loop While Not rngFind Is Nothing And strFirst <> rngFind.Address
    If Not rngCopy Is Nothing Then rngCopy.Copy Range("A4")
  End If
End With
End Sub

https://www.herber.de/bbs/user/118821.xlsm
Der Suchbegriff kann auch Widcards enthalten!
Gruß Sepp

Anzeige

362 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige