For each cell in Range - wo ist der Fehler
Peter Ziegert
ich will mit for each einen Range durchlaufen und mit jede Zelle
ansehen. Leider klappt der folgende Code nicht. Kann mir da jemand
aushelfen?
Vielen Dank.
Viele Grüße,
Peter
Public Sub SpalteUebernehmen()
Dim ws1, ws2 As Worksheet
Dim cell, rng_quelle, rng_such, rng_kopie, rng_ziel As Range
Dim such_zeile, quellen_zeile, lngSpalte, lngZeile As Long
such_zeile = 1
quellen_zeile = 1
'Worksheets Namen eintragen
Set ws1 = ActiveWorkbook.Worksheets("Quelle")
Set ws2 = ActiveWorkbook.Worksheets("Ziel")
'Range Quelle angeben - Zeile eintragen
Set rng_quelle = ws1.Rows(quellen_zeile)
'Range Ziel - Suchkriterium eingeben
Set rng_such = ws2.Rows(such_zeile)
'For Each cell In Selection
For Each cell In rng_such
If Not IsEmpty(cell.Value) Then
lngSpalte = rng_quelle.Find(What:=cell.Value).Column
ws1.Activate
lngZeile = Cells(Rows.Count, lngSpalte).End(xlUp).Row
Set rng_kopie = ws1.Range(Cells(quellen_zeile + 1, lngSpalte),
Cells(lngZeile, lngSpalte))
ws2.Activate
Set rng_ziel = ws2.Range(Cells(such_zeile + 1, cell.Column),
Cells((lngZeile - quellen_zeile + such_zeile), cell.Column))
rng_ziel.Value = rng_kopie.Value
End If
Next
End Sub
Alexander Wolff
lie�
Peter Ziegert verlautbaren, evtl. nachfolgend zitiert:
> Public Sub SpalteUebernehmen()
>
> Dim ws1, ws2 As Worksheet
> Dim cell, rng_quelle, rng_such, rng_kopie, rng_ziel As Range
Leider akzeptiert VBA keine gemeinsame AS ...-Zuweisung.
Du mussst also alles einzeln als AS Range zuweisen.
Ein Fehler taucht bei Dir nicht auf, weil cell-rng_kopie als Variant
deklariert werden.
Das gilt auch f�r die danach folgende AS Long-Deklaration.
--
Moin+Gruss Alexander - MVP for MS Excel - www.xxcl.de - mso2000sp3 --7-2
Peter Ziegert
Vielen Dank. Habe jetzt alles einzeln zugewiesen. Leider wird in der
for-Schleife noch immer nicht jede Zelle des rng_such durchlaufen.
Gebe ich statt
For Each cell In rng_such
For Each cell In Selection
ein und wähle den entsprechenden Bereich aus, dann läuft es. Woran
liegt das?
Und weiß auch jemand, warum ich die die Worksheets in der for-Schleife
aktivieren muss (ws1.Activate), um die set Range Anweisung machen zu
können?
Andreas Killer
> ich will mit for each einen Range durchlaufen und mit jede Zelle
> ansehen. Leider klappt der folgende Code nicht. Kann mir da jemand
> aushelfen?
Schaun wir mal...
> Dim ws1, ws2 As Worksheet
> Dim cell, rng_quelle, rng_such, rng_kopie, rng_ziel As Range
> Dim such_zeile, quellen_zeile, lngSpalte, lngZeile As Long
Diese Zuweisung erzeugt alle Variablen ohne ein "As" als "Variant",
was aber nicht soooo schlimm ist. Daran liegt's nicht.
> 'Range Quelle angeben - Zeile eintragen
> Set rng_quelle = ws1.Rows(quellen_zeile)
>
> 'Range Ziel - Suchkriterium eingeben
> Set rng_such = ws2.Rows(such_zeile)
>
> 'For Each cell In Selection
> For Each cell In rng_such
Ah ja, sieht auf den ersten Blick okay aus, ist es aber nicht. Ein
Debug.Print cell.Address
an dieser Stelle bringt Aufschlu�, Cell ist "1:1", d.h. die ganze
Zeile. Ein
For Each cell In rng_such.Cells
bringt das gew�nschte Verhalten.
> lngSpalte = rng_quelle.Find(What:=cell.Value).Column
Das geht nicht, aus mehreren Gr�nden:
a.) Find sucht mit den letzten Einstellungen, d.h. entweder ganze
Zelle oder nur Teil der Zelle / in Formeln oder Werten / etc.
b.) Schl�gt die Suche fehl, weil nicht gefunden, dann gibt Find
Nothing zur�ck und Nothing.Column gibt den Fehler.
> ws1.Activate
Warum schaltest Du hier zwischen den Sheets hin und her? Bisher hast
Du sehr sch�n referenziert, das geht hier auch.
> lngZeile = Cells(Rows.Count, lngSpalte).End(xlUp).Row
> Set rng_kopie = ws1.Range(Cells(quellen_zeile + 1, lngSpalte),
> Cells(lngZeile, lngSpalte))
> ws2.Activate
> Set rng_ziel = ws2.Range(Cells(such_zeile + 1, cell.Column),
> Cells((lngZeile - quellen_zeile + such_zeile), cell.Column))
> rng_ziel.Value = rng_kopie.Value
Hier treibst Du einen recht hohen Aufwand um nur den Datenbereich der
Spalte zu kopieren, hingegen l�uft Deine FOR-Schleife �ber alle Spalten.
Ich reduziere das alles mal auf das wesentliche.
Andreas.
Public Sub SpalteUebernehmen()
Dim C As Range, R As Range
'Alle Zellen in Zeile 1 im Ziel durchlaufen
For Each R In Sheets("Ziel").Rows(1).Cells
'Leer?
If Not IsEmpty(R) Then
'In Zeile 1 der Quelle suchen
Set C = Sheets("Quelle").Rows(1).Cells.Find(R, LookIn:= _
xlValues, LookAt:=xlWhole)
'Gefunden?
If Not C Is Nothing Then
'Daten der Spalte kopieren
Sheets("Ziel").Columns(R.Column) = Sheets("Quelle") _
.Columns(C.Column).Value
End If
Peter Ziegert
Viele Grüße,
Peter