Überprüfen von Zellen mit VBA

[Hummingbeard]

Hallo ihr Lieben,

folgenden Vorgang versuche ich seit einer Stunde in VBA umzusetzen:
In einem Tabellenblatt werden die Zellen einer Spalte (E2 - E30) auf Inhalt überprüft. Falls in der Zelle etwas steht, soll der Inhalt der ersten Zelle aus der betreffenden Reihe kopiert und in die erste freie Zeile eines anderen Tabellenblattes kopiert werden.
Der zugehörige Code sieht folgendermaßen aus und macht nicht, was er soll:

Code:

Sub Bes4()
    Dim rng As Range
    Dim cell As Range
   
    Sheets("K_5").Select
    Set rng = Range("E2:E30")
    For Each cell In rng
     If IsEmpty(cell.Value) = False Then
        Cells(ActiveWindow.RangeSelection.Row, 1).Select
        Selection.Copy
        Sheets("4_Bes").Select
        Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
       
     End If
    Next

End Sub

Vielen Dank schonmal für eure Hilfe!
HB

[{Boris}]

Hi,

Blattnamen auf Deine Gegebenheiten anpassen!

Code:

Option Explicit

Sub til()
Dim wksQuell As Worksheet
Dim wksZiel As Worksheet
Dim rngSearch As Range
Dim C As Range
Dim lngRow As Long
Set wksQuell = Worksheets("K_5") 'Quellblatt - anpassen!
Set wksZiel = Worksheets("4_Bes") 'Zielblatt - anpassen!
Set rngSearch = wksQuell.Range("E2:E20")
With wksZiel
    lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 'freie Zeile im Zielblatt anhand Spalte A (1) ermitteln
    For Each C In rngSearch
        If Len(C) Then
            .Cells(lngRow, 1).Value = wksQuell.Cells(C.Row, 1).Value
            lngRow = lngRow + 1
        End If
    Next C
End With
End Sub

[Egon12]

Hallo,

das sollte so passen:

Code:

Sub UebertragenWenn()
    Dim iStart As Long, iEnde As Long, i As Long
    With Sheets("K_5")
        For i = 2 To 30
            If .Cells(i, 5) <> "" Then
                iStart = i
                Exit For
            End If
        Next i
    If iStart = 0 Then Exit Sub
        .Range("E" & iStart & ":E" & .Cells(Rows.Count, 5).End(xlUp).Row).Copy
    End With
    With Sheets("4_Bes")
        .Cells(.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlPasteValues
    End With
End Sub

Gruß Uwe

[Hummingbeard]

Vielen Dank Boris,

funktioniert einwandfrei! :)

[snb]

oder

Code:

Sub M_snb()
  for each it in sheets("K-5").range("E2:E30").specialcells(2)
    sheets("4-Bes").cells(it.row,columns.count).end(xltoleft).offset(,1)=it.offset(,-4).value
  next
End Sub

[Hummingbeard]

Hallo nochmal,

ich bin zum zweiten Mal auf eure Hilfe angewiesen, da sich die Anforderungen geändert haben. Vermutlich ist es am besten, wenn ich das Problem nochmal in seiner Gesamtheit beschreibe. Die Neuerungen habe ich farbig gemacht.

In einem Tabellenblatt werden die Zellen einer Spalte (E2 - E30) auf Inhalt überprüft. Falls in einer der Zellen etwas steht und nicht fett geschrieben ist, soll der Inhalt der ersten Zelle aus der betreffenden Reihe kopiert und in die erste freie Zeile eines anderen Tabellenblattes übertragen werden. In die Zelle rechts daneben soll der Name des Urprungsblattes eingefügt werden und wiederum eine Zelle weiter rechts soll das aktuelle Datum eingefügt werden. Sobald das geschehen ist, soll der Inhalt der Ursprungszelle fett geschrieben werden, damit bei einer erneuten Überprüfung der Wert nicht mehrfach übernommen wird.

Ich hoffe, ich habe das nachvollziehbar beschrieben. Dass der Zelleninhalt auf fett / nicht fett überprüft wird, muss natürlich nicht so umgesetzt werden, falls das anders einfacher geht.
Leider übersteigt das meine bescheidenen VBA-Kenntnisse und Herr Google konnte hier auch nicht mehr helfen...

Schon jetzt vielen Dank für eure Hilfe!

HB

[Klaus-Dieter]

Hallo,

Auswertungen nach Zellformaten sind keine gute Idee.

[Hummingbeard]

Hallo Klaus-Dieter,

danke für dein Feedback.
Im Prinzip geht es ja nur darum, dass bereits übernommene Zellenwerte nicht bei jeder Aktivierung des Makros erneut übertragen werden. Gibt es dafür eine andere Möglichkeit als die Änderung und Auswertung des Zellformats?

Viele Grüße
HB

[snb]

Wie einfach:

Code:

Sub M_snb()
  Sheets("K_5").Range("E2:E30").SpecialCells(2).Copy sheets("4-Bes").Cells(rows.count,1).end(xlup).offset(1)
  sheets("4-Bes").Columns(1).RemoveDuplicates 1
End Sub

[00202]

Hallo,  

hier mal zwei Beispiele:  
[attachment=44851]

Einmal über "Fett" - und einmal über die Evaluierung der Formel "EINDEUTIG".