AW: Auswahl aus Tabellenblatt in 2. Tabellenblatt
08.08.2003 09:13:31
Erich M.
Hallo Barbara,
wäre das evtl. ein Ansatz; die Tabellennamen, Suchbegriffe müssten ebtsprechend angepasst werden:
Sub Suchenkopieren_eineTabelle()
'http://www.herber.de/forum/archiv/224to228/t225904.htm
'Re: suchen und kopieren von: Ramses Geschrieben am: 01.03.2003 - 14:13:39
' mehrmals geändert Erich M.
Dim wks As Worksheet
Dim rng As Range
Dim sAddress As String, sFind As String
Dim Cr As Long, tarWks As String
Dim mySpalte As String
Dim myName2 As String, Tb(1 To 15) As Worksheet, gefunden As Boolean
sFind = InputBox("Bitte Suchbegriff eingeben:")
myName2 = InputBox("Tabellenname")
For Each Tb(3) In ThisWorkbook.Worksheets
If Tb(3).Name = "Doppelte" Then gefunden = True: Exit For
Next
If Not gefunden Then
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Doppelte"
End If
Set Tb(3) = ThisWorkbook.Worksheets("Doppelte")
With Tb(3)
.Cells.Clear
.Cells(1, 1) = "Der gesuchte Wert " & sFind & " wurde so oft in der Tabelle " & myName2 & " gefunden "
End With
'myName2 = InputBox("Tabellenname")
tarWks = "Doppelte" ' Zieltabelle
Cr = 65536
If Worksheets(tarWks).Cells(Cr, 1) = "" Then
Cr = Worksheets(tarWks).Cells(Cr, 1).End(xlUp).Row
End If
If Cr = 1 Then Cr = 2
'For Each wks In Worksheets
' If wks.Name = tarWks Then GoTo Exitfor
Sheets(myName2).Activate
Set rng = Cells.Find(what:=sFind, _
lookat:=xlWhole, LookIn:=xlFormulas)
If Not rng Is Nothing Then
sAddress = rng.Address
Do
Application.Goto rng, True
' If MsgBox("Weiter und kopieren", vbYesNo + vbQuestion) = vbNo Then Exit Sub
Sheets(myName2).Rows(rng.Row).Copy Destination:=Worksheets(tarWks).Rows(Cr)
Cr = Cr + 1
Set rng = Cells.FindNext(after:=ActiveCell)
If rng.Address = sAddress Then Exit Do
Loop
End If
'Exitfor:
'Next wks
'MsgBox prompt:="Keine neue Fundstelle!"
Worksheets("Doppelte").Select
Range("B2").Select
ActiveWindow.FreezePanes = True
Range("G1").Select
End Sub
Code eingefügt mit: Excel Code Jeanie
mfg
Erich