Portal | Forenübersicht | Neues Thema | Suchen | FAQ | Registrieren | Login
Forum > Excel & VBA > Code-Archiv > Zellen suchen, Zellbereiche kopieren
Fragen zu Codes und Formeln aus dem Code-Archiv
In diesem Board befinden sich 7 Themen.
Die Beiträge bleiben immer erhalten.
Es wird moderiert von P@ulchen, RO_SCH.
Seite 1 Neues Thema letztes Thema nächstes Thema Dieses Board durchsuchen Diesen Thread zu meinen persönlichen Favoriten hinzufügen Abonnieren Ohne Zitat Antworten Druckt alle Antworten dieses Themas


Richi ist offline Richi  Zellen suchen, Zellbereiche kopieren Antworten Zitatantwort Einzelbeitrag drucken Dieses Thema weiterempfehlen
Profil private Nachricht senden Email
5.9.2008 - 9:54 Uhr
2 Posts
Junior


Hallo Excel - Freunde,

das Thema übersteigt meinen Excel - Horizont.

Ich möchte einen vorgegebenen Wert "X" (Text und oder Zahl) in der Spalte A der Tabelle suchen.
Zu jedem "X" soll 3 Spalten rechts der zugehörige Wert "Y'"
in eine neue Tabelle, in der nächsten freien Spalte kopiert werden.

Der Wert "X" kann bis 200 mal in der Tabelle mit ca. 2000 Daten-Zeilen auftauchen. Ich brauche also einen Code der das Problem schnell erledigt

Wäre super wenn mir jemand helfen würde

Grüsse
Richi

RO_SCH ist offline RO_SCH  Re: Zellen suchen, Zellbereiche kopieren Antworten Zitatantwort Einzelbeitrag drucken Dieses Thema weiterempfehlen
Profil private Nachricht senden
5.9.2008 - 16:15 Uhr
2406 Posts
Super-Moderator


Hi Richi,

herzlich willkommen in der Excel-Werkstatt.

versuch es doch mal damit.

Zitat:
Private Sub Suchen()
Dim xSuche, xAdresse, xErste As String
Dim y As Boolean
Dim arr() As Variant
Dim rng As Range
Dim i As Integer, iRowU As Integer, aletzte As Integer

xSuche = Range("H1")
If xSuche = "" Then
MsgBox "Bitte erst einen Suchbegriff in 'H1' eingeben!", vbExclamation, "Achtung!"
Exit Sub
End If

With Tabelle1
Set rng = .Range("A:A").Find _
(xSuche, lookat:=xlWhole, LookIn:=xlValues)
If Not rng Is Nothing Then
xErste = rng.Address(False, False)
y = True
Do Until xAdresse = xErste
ReDim Preserve arr(0 To iRowU)
arr(iRowU) = rng.Offset(0, 3).Value
iRowU = iRowU + 1
Set rng = .Cells.FindNext(after:=rng)
xAdresse = rng.Address(False, False)
Loop
xAdresse = ""
xErste = ""
End If
End With
If y = False Then
MsgBox "Der Suchbegriff wurde nicht gefunden!"
Else
For i = LBound(arr) To UBound(arr)
With Tabelle2
aletzte = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Cells(aletzte, 1) = arr(i)
End With
Next i
End If
End Sub


Gruß Roland

Richi ist offline Richi  Re: Zellen suchen, Zellbereiche kopieren Antworten Zitatantwort Einzelbeitrag drucken Dieses Thema weiterempfehlen
Profil private Nachricht senden Email
8.9.2008 - 11:42 Uhr
2 Posts
Junior


Hallo Roland,


vielen Dank ! Du bist eine Wucht
Es funktioniert !!!

Ich habe allerdings ein Problem:

Bei erneuter Suche der "X" und Kopie von "Y" in Tabelle2 werden die neuen "Y" in dieselbe Spalte der nächsten freien Zeile kopiert.
Die neuen Werte "Y" sollen aber in die nächste freie Spalte kopiert werden.
Da Dein VBA - Code für mich Neuland ist will ich nichts an dem Code ändern.

Bitte nochmal um Unterstützung

Vielen Dank im Vorraus

Grüsse Richi

RO_SCH ist offline RO_SCH  Re: Zellen suchen, Zellbereiche kopieren Antworten Zitatantwort Einzelbeitrag drucken Dieses Thema weiterempfehlen
Profil private Nachricht senden
8.9.2008 - 16:44 Uhr
2406 Posts
Super-Moderator


Hi Richi,

dazu brauchen wir nur einen als Public dimensionierten Zähler einzufügen, der hochgezählt wird, wenn etwas bei der Suche gefunden wurde.

Könnte so aussehen:
Zitat:
Public Zähler As Integer

Private Sub Suchen()
Dim xSuche, xAdresse, xErste As String
Dim y As Boolean
Dim arr() As Variant
Dim rng As Range
Dim i As Integer, iRowU As Integer, aletzte As Integer

xSuche = Range("H1")
If xSuche = "" Then
MsgBox "Bitte erst einen Suchbegriff in 'H1' eingeben!", vbExclamation, "Achtung!"
Exit Sub
End If

With Worksheets("Tabelle1")
Set rng = .Range("A:A").Find _
(xSuche, lookat:=xlWhole, LookIn:=xlValues)
If Not rng Is Nothing Then
xErste = rng.Address(False, False)
y = True
Do Until xAdresse = xErste
ReDim Preserve arr(0 To iRowU)
arr(iRowU) = rng.Offset(0, 3).Value
iRowU = iRowU + 1
Set rng = .Cells.FindNext(after:=rng)
xAdresse = rng.Address(False, False)
Loop
xAdresse = ""
xErste = ""
End If
End With
If y = False Then
MsgBox "Der Suchbegriff wurde nicht gefunden!"
Else
Zähler = Zähler + 1
For i = LBound(arr) To UBound(arr)
With Worksheets("Tabelle2")
aletzte = .Cells(Rows.Count, Zähler).End(xlUp).Row + 1
.Cells(aletzte, Zähler) = arr(i)
End With
Next i
End If
End Sub


Gruß Roland

Seite 1 nach oben

Forenauswahl:





Numaek's Forum V4.1.0 © 2005 by numaek
Originaltemplate by numaek