VBA und Excel

Computer: Software & Programmierung Visual Basic
#1

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

#2

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

#3

Danke fuer deinen Tip, aber es funktioniert leider noch nicht.

#4

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

#5

Hi Timo,
super Sache, jetzt funktioniert es :smile: juhu
Vielen Dank und Viele Gruesse Chris

#6

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

#7

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