AW: Über Inputbox namen suchen, kopieren und einfügen.
11.07.2011 22:39:04
fcs
Hallo Hans,
hier mein Vorschlag aus meinem Bestand, etwas angepasst an deine Wunschliste (kopieren in neue Datei).
Gruß
Franz
Sub aSuchen_Name()
Dim vAuswahl
Do
vAuswahl = InputBox(Prompt:="Bitte zu suchenden Namen eingeben", _
Title:="Name Suchen und Kopieren")
If vAuswahl "" Then
Call Suchen_Kopieren(wksQuelle:=ActiveSheet, varSuchen:=vAuswahl, _
Spalte:=11, ZeileStart:=2)
Else
Exit Do
End If
Loop
End Sub
Sub Suchen_Kopieren(wksQuelle As Worksheet, varSuchen, _
Optional Spalte As Long = 1, Optional ZeileStart As Long = 1)
'Durchsucht eine Spalte der Quelltabelle nach dem Suchbegriff und _
kopiert gefundene Zeilen in die Zieltabelle. Gesucht wird nach Übereinstimmumg _
des gesamten Zellwertes
'wksQuelle = Tabellenblatt in dem gesucht werden soll
'wksZiel = Tabelle in die die gefundenen Zeilen kopiert werden sollen
'varSuchen = Suchbegriff
'Spalte = Nr. der zu durchsuchenden Spalte
'ZeileStart = Nr. der Zeile ab der gesucht werden soll
Dim rngZelle As Range, ZeileZiel As Long, strZelle1 As String, rngBereich As Range
Dim ZeileLetzte As Long
Dim wbNeu As Workbook, sName As String, wksZiel
With wksQuelle
'letzte Datenzeile in Suchspalte der Quelltabelle
ZeileLetzte = .Cells(.Rows.Count, Spalte).End(xlUp).Row
If ZeileLetzte >= ZeileStart Then
'Suchbereich setzen
Set rngBereich = .Range(.Cells(ZeileStart, Spalte), .Cells(ZeileLetzte, Spalte))
'Suchbegriff suchen
Set rngZelle = rngBereich.Find(What:=varSuchen, LookIn:=xlValues, _
lookat:=xlWhole)
If rngZelle Is Nothing Then
MsgBox "Suchbegriff """ & varSuchen & """ nicht gefunden!"
Else
sName = rngZelle.Text
If wbNeu Is Nothing Then
'Neue Arbeitsmappe orbereiten
Set wbNeu = Workbooks.Add(Template:=xlWBATWorksheet) 'Mappe mit Standardtabelle _
evtl. hier als eine Vorlage mit einer vorformatieren Tabelle angeben als Template
Set wksZiel = wbNeu.Worksheets(1)
'Spaltenformate kopieren
wksQuelle.UsedRange.EntireColumn.Copy
wksZiel.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
ZeileZiel = 0 'Startzähler für Zeilen im Zielblatt
End If
'1. Fundstelle merken
strZelle1 = rngZelle.Address
Do
ZeileZiel = ZeileZiel + 1
rngZelle.EntireRow.Copy Destination:=wksZiel.Cells(ZeileZiel, 1)
'nächste Fundstelle suchen
Set rngZelle = rngBereich.FindNext(After:=rngZelle)
Loop Until rngZelle.Address = strZelle1
wksZiel.Activate
Range("A1").Select
'Name der neuen Datei ermitteln
With wksQuelle.Parent
sName = Left(.FullName, InStrRev(.FullName, ".") - 1) & " " & sName
End With
With wbNeu
'Fileformat ggf. anpassen
.SaveAs Filename:=sName, FileFormat:=xlWorkbook, addtomru:=False
MsgBox "Fertig mit Suchen und Kopieren"
.Close
End With
End If
Else
MsgBox "Keine Daten im Suchbereich der Quell-Tabelle"
End If
End With
End Sub