VBA Liste in Tabelle1 eintragen Tabelle2 bereinigen
03.10.2020 01:05:16
Sedat
Bei der Abarbeitung der Täglichen Punkte Liste, können wir nur per Zeilen Angabe die Werte Eintragen.
Wir würden es Gerne Per VBA Schleife die Liste einfach durchlaufen lassen, bekommen es aber nicht hin.
kann uns jemand behilflich sein.
am Beispiel sehen sie es funktioniert wenn wir z.B die Zeile 4 in die Zelle eintrage und den VBA macro starten wird es eingetragen und gesäubert.
nur bei dem Versuch uber eine Schlefe sind wir getolpert. grinz.
Bitten um Hilfe?
der File ist 400 KB gross konnte es nicht kleiner machen. daher ein Google Drive Link.
Am Beispiel,
https://drive.google.com/file/d/1AjS2fIwMQInfavKVktS3rVgvbZvVw_rM/view?usp=sharing
' ---
Sub Eintragung_Schleife()
Dim Zelle As Range
Dim a As Long
a = 4 'Start Zeile
With Worksheets("SpielReport")
For Each Zelle In .Range("P4:P10") ' Alle Zeilen die "OK" beinhalten Range(P4:P3000)
If Zelle = "OK" Then
With ActiveCell
' ---- Start Loop und Eintragen -----
Dim aktZeile, vglZeile, vglSpalte As Integer
vglZeile = Cells(a, 18) 'Spalte R
vglZeile2 = Cells(a, 19) 'Spalte S
vglSpalte = Cells(a, 20) 'Spalte T
vglSpalte2 = Cells(a, 28) 'Spalte AB
vglRange = Cells(a, 29)
Wert = Cells(a, 27) 'Spalte AA
aktZeile = vglZeile
With ThisWorkbook.Sheets("MMS")
While .Cells(aktZeile, vglSpalte) ""
aktZeile = aktZeile + 1
Wend
.Cells(aktZeile, vglSpalte) = Cells(a, 27) 'Spalte AA
.Cells(aktZeile, vglSpalte + 11) = Cells(a, 24) 'Spalte X
.Cells(aktZeile, vglSpalte + 22) = Cells(a, 23) 'Spalte W
End With
Dim FindString As String
Dim rng As Range
FindString = Wert
If Trim(FindString) "" Then
With Sheets("MMS").Range(vglRange) 'Sheet spalte Cells(a, Q) .Range($AF$14:$AF$15) _
Spalte Z
Set rng = .Find(What:=FindString, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not rng Is Nothing Then
rng = "" ' Wert löschen innerhalb der .Range $AF$14:$AF$15)
Else
End If
End With
End If
' ---- Ende Eintrag Ende Loop -----
End With
a = a + 1
End If
Next
End With
End Sub
'---
Lieben Gruss