also in der arbeitsmappe steht:Private Sub Workbook_Open()
GetObject ("C:\abl\Daten.xls")
End Sub
! Ist erforderlich da sonst die folgende Volltextsuche nicht funzt die in Tabelle1 "Berechnungs Eingabe" eingebettet ist.
Private Sub ListBox1_Click()
Workbooks("Daten.xls").Sheets(1).Range("A" & CStr(ListBox1.List(ListBox1.ListIndex, 1)) & ":G" & CStr(ListBox1.List(ListBox1.ListIndex, 1))).Copy ActiveSheet.Range("A1:G1")
End Sub
Private Sub TextBox1_Change()
Dim Zelle As Range, Adresse As String
ListBox1.Clear
With Workbooks("Daten.xls").Sheets(1).Range("A2:G9999")
Set Zelle = .Find(What:=TextBox1.Value, LookAt:=xlPart)
If Not Zelle Is Nothing Then
Adresse = Zelle.Address
Do
ListBox1.AddItem Zelle.Value
ListBox1.List(ListBox1.ListCount - 1, 1) = Zelle.Row
Set Zelle = .FindNext(Zelle)
Loop While Not Zelle Is Nothing And Zelle.Address <> Adresse
End If
End With
If Adresse <> "" Then Call sortieren(0, ListBox1.ListCount - 1)
End Sub
Private Sub sortieren(Untergrenze As Long, Obergrenze As Long)
Dim index1 As Long, index2 As Long, Element1 As String, Element2 As Long, Zwischenspeicher As String
index1 = Untergrenze
index2 = Obergrenze
Zwischenspeicher = ListBox1.List(((Untergrenze + Obergrenze) / 2) \ 1, 0)
Do
Do While ListBox1.List(index1, 0) < Zwischenspeicher
index1 = index1 + 1
Loop
Do While Zwischenspeicher < ListBox1.List(index2, 0)
index2 = index2 - 1
Loop
If index1 <= index2 Then
Element1 = ListBox1.List(index1, 0)
Element2 = ListBox1.List(index1, 1)
ListBox1.List(index1, 0) = ListBox1.List(index2, 0)
ListBox1.List(index1, 1) = ListBox1.List(index2, 1)
ListBox1.List(index2, 0) = Element1
ListBox1.List(index2, 1) = Element2
index1 = index1 + 1
index2 = index2 - 1
End If
Loop Until index1 > index2
If Untergrenze < index2 Then Call sortieren(Untergrenze, index2)
If index1 < Obergrenze Then Call sortieren(index1, Obergrenze)
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub
hiermit wird permanent nach Treffern gesucht und muss immer Ausgeführt sein.
wenn nun jedoch die abgefragte Adresse nicht vorhanden ist, muss mann sie anlegen dazu wird die Adresse 1zeilig und 7spaltig angegeben, bei cklick auf Übernehmen kommt dieses script zum tragen:
Sub Übernehmen_der_Daten_Click()
Dim Reihe As String
Reihe = ActiveCell.Row
Range(Cells(Reihe, 1), Cells(Reihe, 7)).Copy
Workbooks.Open Filename:="C:\abl\Daten.xls"
Sheets("Daten").Activate
Range("A1").Select
ActiveCell.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWindow.Close
Sheets("Berechnungs Eingabe").Select
Application.CutCopyMode = False
End Sub
welches jetzt aber einen Fehler gibt weil die Datei Daten.xls bereits geöffnet ist, ansich muss das Übernahme Script doch nur so abgeändert werden das es nicht Daten.xls öffnet sondern aktiviert und nach dem Eintrag speichert und wieder deaktiviert (nicht schliessen, da sonst die Volltextsuche nicht mehr geht)
MfG Bernd Schneider