AW: Autofilter mit Combobox
04.12.2007 07:36:00
christian
servus
was du vor hast ist wirklich nicht einfach!
ich bin auch anfäger und ich habe das so gelöst .
du brauchst dazu eine userform mit einer listbox1 und 2 command button und eine leere tabelle
fazit.
du drückst in der userform auf suchen die gefundene datensätze werden in die leere tabelle kopiert und stehen bereit in der zwischenablage.
Sub MultiSelect()
Dim wks As Worksheet
Dim rngFind As Range, rngRows As Range
Dim lngRow As Long
Dim strFind As String, strSearch As String
'TEBELLE VOR DEM EINFÜGEN LEEREN
Application.ScreenUpdating = False
Sheets("Suchwerte").Select
Columns("A:F").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
Sheets("Vergleich").Select
'suchbeginn
strSearch = InputBox("Suchbegriff:", , "Maier")
Set rngFind = Cells.Find(strSearch)
If rngRows Is Nothing Then
Set rngRows = rngFind
End If
If Not rngFind Is Nothing Then
strFind = rngFind.Address
Do
Set rngRows = Application.Union(rngRows, rngFind.EntireRow)
Set rngFind = Cells.FindNext(After:=rngFind)
If rngFind.Address = strFind Then Exit Do
Loop
End If
rngRows.Select
Selection.Copy
Cells(1, 1).Select
'TEST BEGINN
'EINFÜGEN
Sheets("Suchwerte").Select
Range("A1").Select
ActiveSheet.Paste
'spaltenberite einstellen
Columns("A:F").Select
Columns("A:F").EntireColumn.AutoFit
Range("B1").Select
Cells(1, 1).Select
Columns("D:D").Select
Selection.Delete Shift:=xlToLeft
Range("B1:D75").Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton1_Click()
Dim strArray() As String, strText As String
Dim lngIndex As Long
Dim objClipboard As DataObject
Set objClipboard = New DataObject
With ListBox1
ReDim strArray(1 To .ListCount)
For lngIndex = 1 To .ListCount
strArray(lngIndex) = .List(lngIndex - 1, 0) & _
vbTab & .List(lngIndex - 1, 1) & _
vbTab & .List(lngIndex - 1, 2) & _
vbTab & .List(lngIndex - 1, 3) & _
vbTab & .List(lngIndex - 1, 4)
Next
End With
strText = Join(strArray, vbLf)
With objClipboard
.SetText strText
.PutInClipboard
End With
Set objClipboard = Nothing
MsgBox ("Alle Daten der Suchabfrage wurden in die Zwischenablage von Windows Kopiert")
Application.Wait Now + TimeSerial(0, 0, 2)
Unload Me
End Sub
gruss
christian neu