Mehrere Zellen nacheinander kopieren, prüfen und wenn dann

312 Aufrufe
Gefragt 17, Feb 2017 in Tabellenkalkulation von MarionF
Hallo.
Dies ist das erste Mal das ich in einem Forum eine Frage stelle und hoffe es klappt und ich schreibe es verständlich genug.

Ich habe in den Spalten A-D die werte 0000 bis 9999 (also 10000 Zeilen) gelistet.
Diese sollen nacheinander immer in den Bereich I1-L1 kopiert werden. Beginnend mit A1-D1. Sie durchlaufen dann eine mathematische Prüfung/Veränderung (die ich schon hinbekommen habe), die sich nach unten aufbaut. Dabei verändern sich in jeder Zeile (I2-L2 bis Ix-Lx) die Werte. Sobald die Summe dieser 4 Zeilenwerte gleich 0 ist soll die Zeilenzahl "x" hinter die kopierten Werte - in ersten Fall A1-D1 - in die Spalte E eingetragen werden UND es sollen die nächsten Werte überprüft werden. Es sollen dann also die Werte A2-D2 in die Zellen I1-L1 kopiert werden. Dieser Vorgang soll über die 10000 Zeilen erfolgen.

Ich danke jetzt schon mal für eventuelle Hilfe.

3 Antworten

0 Punkte
Beantwortet 17, Feb 2017 von m-o Profi (11,137 Punkte)
Hallo,

wie erfolgt denn die Prüfung - per Formel oder wird das auch durch ein Makro erledigt?

Gruß

M.O.
0 Punkte
Beantwortet 17, Feb 2017 von MarionF
Hallo.
Durch eine Formel in jeder Zelle.

In I2 =ABS(I1-J1)
In J2 =A:BS(J1-K1)
In K2 =ABS(K1-L1)
In L2 =ABS(L1-I1)

VG
0 Punkte
Beantwortet 20, Feb 2017 von m-o Profi (11,137 Punkte)
Hallo,

ich hoffe , ich habe dich richtig verstanden. Das folgende Makro gehört in ein
Standard-Modul deiner Arbeitsmappe:

Sub kopieren()

Dim dblDaten
Dim lngLetzte As Long
Dim lngZeile As Long
Dim lngPruef As Long

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Spalte E löschen
Range("E1:E10000").ClearContents

'Letzte Zeile in Spalte I ermitteln
lngLetzte = ActiveSheet.Cells(Rows.Count, 9).End(xlUp).Row

'Daten in Array dblDaten einlesen
dblDaten = ActiveSheet.Range("A1:D10000")

'Zeilen 1 bis 10000 durchlaufen
For lngZeile = 1 To 10000
'Inhalte der einzelnen Zeilen in Spalten I bis L schreiben
For lngPruef = 1 To 4
Cells(1, 8 + lngPruef) = dblDaten(lngZeile, lngPruef)
Next lngPruef

'prüfen, ob Zeilen in Spalten I bis L Null ergeben
For lngPruef = 2 To lngLetzte
If Application.WorksheetFunction.Sum(Range(Cells(lngPruef, 9), Cells(lngPruef, 12))) = 0 Then Cells(lngZeile, 5) = lngPruef
Next lngPruef

Next lngZeile

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

MsgBox "Kopieren beendet", 64, "ENDE"

End Sub


Das Makro muss aus dem Arbeitsblatt, in dem deine Daten stehen, gestartet werden.

Ich weiß nicht ob, du in den Zeilen I3 ff. noch weitere Formel hinterlegt hast, Die von dir geposteten Formeln in den Spalten I2 bis L2 ergeben in der Summe ja nur Null, wenn alle 4 Zahlen gleich sind. Wenn es nur das ist, kann man das auch anders lösen.

Gruß

M.O.
...