Makro kürzen
23.07.2005 11:55:25
Thomas
kann man dieses Makro etwas kürzer gestalten?
Sub FindenUndKopieren()
Dim iRowS As Integer, iRowT As Integer
Dim sWord As String
Dim i As Double
sWord = InputBox( _
prompt:="Suchbegriff:", _
Default:="")
If sWord = "" Then Exit Sub
iRowS = 1
iRowT = 1
With Worksheets("Tabelle2")
Do Until IsEmpty(Cells(iRowS, 1))
If Cells(iRowS, 1) = sWord Then
Rows(iRowS).Copy .Rows(iRowT)
iRowT = iRowT + 1
End If
iRowS = iRowS + 1
Loop
.Columns.AutoFit
.Select
End With
Rows("1:30").Insert Shift:=xlDown
Sheets("Artikel-Verzeichnis").Select
sWord = InputBox( _
prompt:="Suchbegriff:", _
Default:="")
If sWord = "" Then Exit Sub
iRowS = 1
iRowT = 1
With Worksheets("Tabelle2")
Do Until IsEmpty(Cells(iRowS, 1))
If Cells(iRowS, 1) = sWord Then
Rows(iRowS).Copy .Rows(iRowT)
iRowT = iRowT + 1
End If
iRowS = iRowS + 1
Loop
.Columns.AutoFit
.Select
End With
Rows("1:30").Insert Shift:=xlDown
Sheets("Artikel-Verzeichnis").Select
sWord = InputBox( _
prompt:="Suchbegriff:", _
Default:="")
If sWord = "" Then Exit Sub
iRowS = 1
iRowT = 1
With Worksheets("Tabelle2")
Do Until IsEmpty(Cells(iRowS, 1))
If Cells(iRowS, 1) = sWord Then
Rows(iRowS).Copy .Rows(iRowT)
iRowT = iRowT + 1
End If
iRowS = iRowS + 1
Loop
.Columns.AutoFit
.Select
End With
Rows("1:30").Insert Shift:=xlDown
Sheets("Artikel-Verzeichnis").Select
sWord = InputBox( _
prompt:="Suchbegriff:", _
Default:="")
If sWord = "" Then Exit Sub
iRowS = 1
iRowT = 1
With Worksheets("Tabelle2")
Do Until IsEmpty(Cells(iRowS, 1))
If Cells(iRowS, 1) = sWord Then
Rows(iRowS).Copy .Rows(iRowT)
iRowT = iRowT + 1
End If
iRowS = iRowS + 1
Loop
.Columns.AutoFit
.Select
End With
For i = 1000 To 1 Step -1
If Cells(i, 1).Value = "" Then _
Cells(i, 1).EntireRow.Delete
Next i
End Sub
Muss ungefähr 20 bis 50 Artikelnummer so suchen und in Tabelle2 Kopieren.
Für eine Antwort bedanke ich mich bereits jetzt!
Thomas.