Hallo,
ich hab ein kleines Programm geschrieben und sitz nun schon laenger davor und weiss nicht, wieso es nicht funktioniert.
Man kann ein Wort eingeben und dann durchsucht es die ersten zwei Spalten nach diesem Wort im Sheet1 und dann soll es die gefunden Worte die mit dem eingegebenen uebereinstimmen im Sheet2 nacheinander ausgeben. Waere sehr sehr nett und hilfreich wenn ihr mir bei diesem Problem weiter helfen koennt.
Mit freundlichen Gruessen
Christoph Veyhl
Hier waere der Code:
Option Explicit
Dim i As Integer
Dim n As Integer
Dim word As Variant
Dim y As Integer
Dim x As Variant
Sub algo()
word = Application.InputBox(„Please enter your searching word“, „Worteingabe“, , , , , , 2)
For n = 1 To 2
For i = 1 To 100
Cells(i, n).Select
If LCase(Trim(ActiveCell)) = LCase(Trim(word)) Then
x = ActiveCell.Value
Call find_empty_row
End If
Next
Next
End Sub
Sub find_empty_row()
Worksheets(„Sheet2“).Activate
For y = 1 To 100
If Cells(y, 1) = „“ Then
Cells(y, 1).Activate
Exit Sub
End If
Next y
ActiveCell = x
Worksheets(„Sheet1“).Activate
End Sub
Hallo,
Hi,
Sub find_empty_row()
Worksheets(„Sheet2“).Activate
For y = 1 To 100
If Cells(y, 1) = „“ Then
Cells(y, 1).Activate
Exit Sub
Das muss exit for und nicht exit sub heißen
End If
Next y
ActiveCell = x
Worksheets(„Sheet1“).Activate
End Sub
Gruß.Timo
Danke fuer deinen Tip, aber es funktioniert leider noch nicht.
Hi nochmal,
abgesehen davon, dass die Vorgehensweise des Programmes verbessert werden kann, würde ich mal Ausdrücke wie : Wert = Cells(x,y) ändern in
Wert = Thisworkbook.Worksheets(„Sheet1“).Cells(x,y).Value
Dann ist es nämlich eindeutig.
Hier mein Vorschlag:
Public Sub algo()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim a As Integer
Dim b As Integer
Dim c As Integer
Dim suchbegriff As String
Set ws1 = ThisWorkbook.Worksheets("Tabelle1")
Set ws2 = ThisWorkbook.Worksheets("Tabelle2")
suchbegriff = InputBox("Bitte Suchbegriff eingeben:")
For a = 1 To 100
For b = 1 To 2
If LCase(Trim(ws1.Cells(a, b).Value)) = LCase(Trim(suchbegriff)) Then
For c = 1 To 100
If ws2.Cells(c, 1).Value = "" Then
ws2.Cells(c, 1).Value = ws1.Cells(a, b).Value
Exit For
End If
Next c
End If
Next b
Next a
End Sub
Gruß.Timo
Hi Timo,
super Sache, jetzt funktioniert es 
juhu
Vielen Dank und Viele Gruesse Chris
Hi,
jetzt wollte ich das Programm erweitern, dass es nicht nur den Zellenwert in das neue Sheet einfuegt, sondern die komplette Zeile in ein neues Sheet einfuegt. Markieren tut er noch die Zeile aus der er kopieren soll, aber beim einfuegen bekomm ich eine Fehlermeldung…
Hoffe Ihr koennt mir weiterhelfen…
Viele Gruesse Chris
Hier ist der Code:
Option Explicit
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim a As Integer
Dim b As Integer
Dim c As Integer
Dim suchbegriff As String
Private Sub CommandButton1_Click()
Set ws1 = ThisWorkbook.Worksheets(„Sheet1“)
Set ws2 = ThisWorkbook.Worksheets(„Sheet2“)
suchbegriff = InputBox(„Bitte Suchbegriff eingeben:“)
For a = 1 To 100
For b = 1 To 2
If LCase(Trim(ws1.Cells(a, b).Value)) = LCase(Trim(suchbegriff)) Then
ws1.Cells(a, b).Activate
Rows(ActiveCell.Row).Select
Selection.Copy
For c = 1 To 100
If ws2.Cells(c, 1).Value = „“ Then
ws2.Cells(c, 1).Activate
ActiveSheet.Paste
Exit For
End If
Next c
End If
Next b
Next a
End Sub
Hi,
Hi,
warum fängst du wieder mit so nem Kack wie „select“ und „activate“ an?
Public Sub algo()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim a As Integer
Dim b As Integer
Dim c As Integer
Dim suchbegriff As String
Set ws1 = ThisWorkbook.Worksheets("Tabelle1")
Set ws2 = ThisWorkbook.Worksheets("Tabelle2")
suchbegriff = InputBox("Bitte Suchbegriff eingeben:")
For a = 1 To 100
For b = 1 To 2
If LCase(Trim(ws1.Cells(a, b).Value)) = LCase(Trim(suchbegriff)) Then
For c = 1 To 100
If ws2.Cells(c, 1).Value = "" Then
ws1.Rows(a).Copy
ws2.Paste ws2.Rows(c)
'ws2.Cells(c, 1).Value = ws1.Cells(a, b).Value
Exit For
End If
Next c
End If
Next b
Next a
End Sub
Gruß.Timo