Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
380to384
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
380to384
380to384
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Zeilen kopieren

Zeilen kopieren
12.02.2004 23:10:46
helena
Guten Abend
habe kleines Problem, denke ich für Euch Profis
möchte in bestimmten Spalten Begriff suchen und kopieren, CODE ist von CD von
HANS, er funktioniert kann aber SUCHBEREICH nicht einschränken zB nur in A:A
oder A:C ???? sehe es leider nicht

Sub SearchNames()
Dim rng As Range, rngSource As Range, rngStart As Range
Dim varInput As Variant
Dim iRow As Integer
varInput = Application.InputBox( _
prompt:="Geben Sie bitte den Namen ein:", _
Title:="Zeilen kopieren", _
Default:="?", _
Left:=263, _
Top:=169, _
Type:=2)
If varInput = False Then Exit Sub
Set rng = ActiveSheet.Columns("A:B").Find( _
what:=varInput, lookat:=xlWhole, LookIn:=xlValues)
If rng Is Nothing Then
Beep
MsgBox "Suchbegriff nicht gefunden!"
Exit Sub
End If
Set rngStart = rng
Set rngSource = rng.EntireRow
Do
Set rng = Cells.FindNext(After:=rng)
If rng.Address = rngStart.Address Then Exit Do
Set rngSource = Application.Union(rngSource, rng.EntireRow)
Loop
With Worksheets("Tabelle2")
iRow = .Cells(Rows.Count, 1).End(xlUp).Row
If iRow = 1 Then iRow = 15 Else iRow = iRow + 1
rngSource.Copy .Cells(iRow, 1)
'.Columns.AutoFit
End With
End Sub

kopieren sonst funktioniert
DANKE
gruss helena

20
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Zeilen kopieren
12.02.2004 23:31:06
Karl-Otto Reimann
Hallo Helena
Man glaubt es nicht, der kopiert alles.
Aber auch dafür wird es 'was geben.
Gruß
Karl-Otto
AW: Zeilen kopieren
12.02.2004 23:35:30
helena
Hallo Karl-Otto
na bin ich froh, das ich es nicht falsch gesehen obwohl
ich Bereich einschränke
If varInput = False Then Exit Sub
Set rng = ActiveSheet.Columns("A:B").Find( _
what:=varInput, lookat:=xlWhole, LookIn:=xlValues)
bei Set rng Spalte A:A oder A:B, usw......

gruss helena
AW: Zeilen kopieren
12.02.2004 23:37:51
Karl-Otto Reimann
Bis zur Aufklärung:

Sub FilternUndKopieren()
Application.ScreenUpdating = False
Sheets("Tabelle1").Select
With Range("A1")
.AutoFilter Field:=1, Criteria1:="WasWeissIch"
.CurrentRegion.SpecialCells(xlCellTypeVisible).Copy _
Worksheets("Tabelle2").Range("A25")
End With
End Sub

Anzeige
AW: Zeilen kopieren
12.02.2004 23:46:57
helena
Hallo Karl-Otto
es eilt nicht so, kann auch morgen sein, es Zeit für die Nachtruhe
habe die Lösung von CD gewählt wegen INPUTBOX, Ziel und bzw. habe ich
alles angepasst, aber wir geasgt heute Nacht nicht mehr EXCEL raubt
uns den Schlaf oft genug
Gute Nacht, es reicht problemlos morgen
gruss helena
AW: Zeilen kopieren
13.02.2004 00:04:05
Karl-Otto Reimann
Sowas läßt mir keine Ruhe, hätte ich den Spagetticode nur durchgelesen:
EntireRow und Union bilden den Suchbereich (war übrigens oft Gegenstand
offengebliebener Threads). Manche Lösungen sind echt simpel. Der Schnipsel
landet in der Schatztruhe.
In diesem Sinne:

Sub SearchNames()
Dim rng As Range, rngSource As Range, rngStart As Range
Dim varInput As Variant
Dim iRow As Integer
varInput = Application.InputBox( _
prompt:="Geben Sie bitte den Namen ein:", _
Title:="Zeilen kopieren", _
Default:="?", _
Left:=263, _
Top:=169, _
Type:=2)
If varInput = False Then Exit Sub
Set rng = ActiveSheet.Columns("A:A").Find( _
what:=varInput, lookat:=xlWhole, LookIn:=xlValues)
If rng Is Nothing Then
Beep
MsgBox "Suchbegriff nicht gefunden!"
Exit Sub
End If
Set rngStart = rng
Set rngSource = rng
Do
Set rng = Cells.FindNext(After:=rng)
If rng.Address = rngStart.Address Then Exit Do
Loop
With Worksheets("Tabelle2")
iRow = .Cells(Rows.Count, 1).End(xlUp).Row
If iRow = 1 Then iRow = 15 Else iRow = iRow + 1
rngSource.Copy .Cells(iRow, 1)
End With
End Sub

Na dann, gute Nacht
Anzeige
leider ... Zeilen kopieren
13.02.2004 07:11:53
helena
Guten Morgen Karl-Otto
Leider nein, jetzt kopiert er nur 1 Zeile und und auch nur
die erste Spalte (A) der Rest wird nicht kopiert
Ziel = wenn in Spalte A (je nach Wahl) zb. als Suchkriterium
ein X steht, soll ganze Zeile kopiert werden und zwar jede
mit X, möchte aber Spaltenbereich für suche im Makro wählen
können A:B oder "C,E" ...
Denke aber dies hast du schon so verstanden
DANKE trotzdem
gruss helena
AW: leider ... Zeilen kopieren
13.02.2004 08:39:23
AndreasS
Morgen,
noch interessiert?
Gruß Andreas
AW: leider ... Zeilen kopieren
13.02.2004 08:45:32
helen
Hallo Andreas
klaro, noch offen
gruss helena
AW: leider ... Zeilen kopieren
13.02.2004 08:48:26
AndreasS
Morgen nochmal,
probier mal das:

Sub Test()
Dim iRow%
With Worksheets(1).Range("A1:C5")
Set c = .Find("X", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Set c = .FindNext(c)
c.EntireRow.Select
With Sheets(2)
iRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
ActiveCell.EntireRow.Copy Worksheets(2).Rows(iRow)
End With
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Sub

Gruß Andreas
Anzeige
AW: leider ... Zeilen kopieren
13.02.2004 08:55:27
helena
Hallo Andreas
geht leider nicht wie gewünscht
siehe bitte ersten Eintrag von mir und weitere
habe es genau (so gut wie möglich beschrieben)
INPUt-BOX etc.
gruss helena
AW: Zeilen kopieren
13.02.2004 09:08:18
Heinz A. Wankmüller
Hallo Helena,
im Makro von Hans ist der Fehler, dass bei der wiederholten Suche nicht mehr die ursprünglich definierten Spalten ("A:B").verwendet werden, sondern cells. Dadurch nimmt er alle Zeilen, in denen der Suchbegriff vorkommt.
ich habe das Makro etwas modifiziert und eine Spaltenauswahl eingebaut allerdings nicht mit Buchstaben, sondern mit Zahlen - war einfacher ;-)
Also die Auswahl der Spalten muss so erfolgen 2,5,6,
ohne Leerzeichen und ein Komma nach jeder Spalte.

Sub SearchNames()
Dim rng As Range, rngSource As Range, rngStart As Range
Dim strSpalten$, intsp%, rngCol As Range, i%
Dim varInput As Variant
Dim iRow As Integer
varInput = Application.InputBox( _
prompt:="Geben Sie bitte den Namen ein:", _
Title:="Zeilen kopieren", _
Default:="?", _
Left:=263, _
Top:=169, _
Type:=2)
If varInput = False Then Exit Sub
strSpalten = InputBox("Geben Sie die Spalten in Zahlen ein, jede gefolgt von einem Komma!")
If strSpalten = "" Then Exit Sub
For i = 1 To Len(strSpalten)
If Mid(strSpalten, i, 1) = "," Then
If rngCol Is Nothing Then
Set rngCol = ActiveSheet.Columns(CInt(Mid(strSpalten, 1, i - 1)))
intsp = i + 1
Else
Set rngCol = Union(rngCol, ActiveSheet.Columns(CInt(Mid(strSpalten, intsp, i - intsp))))
intsp = i + 1
End If
End If
Next i
Set rng = rngCol.Find( _
what:=varInput, lookat:=xlWhole, LookIn:=xlValues)
If rng Is Nothing Then
Beep
MsgBox "Suchbegriff nicht gefunden!"
Exit Sub
End If
Set rngStart = rng
Set rngSource = rng.EntireRow
Do
Set rng = rngCol.FindNext(After:=rng)
If rng.Address = rngStart.Address Then Exit Do
Set rngSource = Application.Union(rngSource, rng.EntireRow)
Loop
With Worksheets("Tabelle1")
iRow = .Cells(Rows.Count, 1).End(xlUp).Row
If iRow = 1 Then iRow = 2 Else iRow = iRow + 1
rngSource.Copy .Cells(iRow, 1)
.Columns.AutoFit
End With
End Sub

Gruß
Heinz
Anzeige
AW: Zeilen kopieren
13.02.2004 09:26:50
helena
Hallo Heinz
funktioniert einwandfrei, schön wäre ich kann
die Spalten fix vergeben, denn ich benötige
ca. 3 Varianten und mit Inputbox passieren Fehler
könntest du mir dort noch helfen
DANKE
gruss helena
AW: Zeilen kopieren
13.02.2004 09:32:48
AndreasS
Hallo,
hier mit Inputbox und festem Bereich:

Sub Test3()
Dim iRow%
Dim i$
i = InputBox("Nach welechem Begriff soll gesucht werden?")
If i Is Nothing Then Exit Sub
With Worksheets(1).Range("A1:C5") 'hier Bereich anpassen
Set c = .Find(i, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Set c = .FindNext(c)
c.EntireRow.Select
With Sheets(2)
iRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
ActiveCell.EntireRow.Copy Worksheets(2).Rows(iRow)
End With
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Sub

Hier mit Bereichsauswahl über Inputbox:

Sub Test()
Dim iRow%
Dim i As String
Dim Bereich As Range
On Error Resume Next
i = InputBox("Nach welechem Begriff soll gesucht werden?")
Set Bereich = Application.InputBox(prompt:="Bereich markieren", Type:=8)
If Bereich Is Nothing Then
MsgBox "Sie haben keinen Bereich ausgewählt"
Exit Sub
Else
Bereich.Select
End If
With Bereich
Set c = .Find(i, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Set c = .FindNext(c)
c.EntireRow.Select
With Sheets(2)
iRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
ActiveCell.EntireRow.Copy Worksheets(2).Rows(iRow)
End With
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Sub

Gruß Andreas
Anzeige
AW: Zeilen kopieren
13.02.2004 09:57:04
helena
Hallo Andreas
das zweite Macro funktionier mit man. Auswahl
beim ersten kommt Typen unverträglich
If i Is Nothing Then Exit Sub
d.h. INPUTBOX öffnet gar nicht zur Auswahl
gruss helena
AW: Zeilen kopieren
13.02.2004 10:01:22
AndreasS
Sorry, es muss natürlich heißen:

Sub Test3()
Dim iRow%
Dim i As String
i = InputBox("Nach welechem Begriff soll gesucht werden?")
If i = "" Then Exit Sub
With Worksheets(1).Range("A1:C5") 'hier Bereich anpassen
Set c = .Find(i, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Set c = .FindNext(c)
c.EntireRow.Select
With Sheets(2)
iRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
ActiveCell.EntireRow.Copy Worksheets(2).Rows(iRow)
End With
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Sub

Gruß Andreas
Anzeige
AW: Zeilen kopieren
13.02.2004 10:00:44
Heinz A. Wankmüller
Hallo Helena,
hier der Code:

Sub SearchNames()
Dim rng As Range, rngSource As Range, rngStart As Range, rngCol As Range
Dim varInput As Variant
Dim iRow As Integer
varInput = Application.InputBox( _
prompt:="Geben Sie bitte den Namen ein:", _
Title:="Zeilen kopieren", _
Default:="?", _
Left:=263, _
Top:=169, _
Type:=2)
If varInput = False Then Exit Sub
Set rngCol = Union(ActiveSheet.Columns("A:D"), ActiveSheet.Columns("F:F"))
Set rng = rngCol.Find( _
what:=varInput, lookat:=xlWhole, LookIn:=xlValues)
If rng Is Nothing Then
Beep
MsgBox "Suchbegriff nicht gefunden!"
Exit Sub
End If
Set rngStart = rng
Set rngSource = rng.EntireRow
Do
Set rng = rngCol.FindNext(After:=rng)
If rng.Address = rngStart.Address Then Exit Do
Set rngSource = Application.Union(rngSource, rng.EntireRow)
Loop
With Worksheets("Tabelle1")
iRow = .Cells(Rows.Count, 1).End(xlUp).Row
If iRow = 1 Then iRow = 2 Else iRow = iRow + 1
rngSource.Copy .Cells(iRow, 1)
.Columns.AutoFit
End With
End Sub

Die Auswahlspalten musst du, wie du sehen kannst in der Zeile
Set rngCol = Union(ActiveSheet.Columns("A:D"), ActiveSheet.Columns("F:F"))

definieren, für einen weiteren Spaltenbereich fügst du einfach ein weiteres Mal ActiveSheet.Columns("F:F")in den Union ein.
Gruß
Heinz
Anzeige
AW: Zeilen kopieren
13.02.2004 10:30:14
helena
Hallo Heinz und Andreas
Lösung Heinz, komme mit UNIONRANGE nicht ganz klar
gesucht soll werden in definierten, Spalten meiner Wahl
und ganze Zeile wird kopiert
Lösung Andreas
Lösung funktioniert soweit ich jetzt getestet habe
einzig wenn Begriff nicht gefunden "EXIT" ohne
MSG unschön Mitarbeiter denkt erledigt wenn keine
Meldung
gruss helena
AW: Zeilen kopieren
13.02.2004 10:50:21
AndreasS
Mit Meldung:

Sub Test4()
Dim iRow%
Dim i As String
i = InputBox("Nach welechem Begriff soll gesucht werden?")
If i = "" Then Exit Sub
With Worksheets(1).Range("A1:C5") 'hier Bereich anpassen
Set c = .Find(i, LookIn:=xlValues)
If c Is Nothing Then
MsgBox ("Daten wurden nicht gefunden")
Exit Sub
End If
If Not c Is Nothing Then
firstAddress = c.Address
Do
Set c = .FindNext(c)
c.EntireRow.Select
With Sheets(2)
iRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
ActiveCell.EntireRow.Copy Worksheets(2).Rows(iRow)
End With
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Sub

Anzeige
Karl-Otto; Heinz; Andreas .....
13.02.2004 11:04:17
helena
Vielen Dank Euch helfern
jetzt läuft es wie gewünscht
gruss helena
Danke für die Rückmeldung...o.T.
13.02.2004 11:12:18
AndreasS
Hi Helena,
danke für die Rückmeldung...
Gruß Andreas

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige