Excel vba Richtiges umkopieren

[atilla]

Hallo Erich,

so müsste es gehen:

Code:

Sub übertragen()
Dim i As Long
Dim lngS As Long
Dim lngZ As Long
Dim lngA As Long
Dim feld

lngS = Application.Max(9, Cells(7, Columns.Count).End(xlToLeft).Column)
lngZ = Application.Max(7, Cells(Rows.Count, "C").End(xlUp).Row)
lngA = Application.CountIf(Range(Cells(7, "F"), Cells(lngZ, "F")), "x")
feld = Range(Cells(7, "C"), Cells(lngZ, "F"))

If lngS = 16 Then
 MsgBox "Übertragfelder voll!"
 Exit Sub
End If

If lngA > 0 Then
For i = 1 To lngZ - 6
 If feld(i, 4) <> "x" Then
   feld(i, 1) = 0
 End If
Next i
Range(Cells(7, lngS + 1), Cells(lngZ, lngS + 1)) = feld
End If

End Sub

EDIT: CODE WAR DOPPELT EINGEFÜGT

Wenn die Zielzellen bis Spalte P gefüllt sind, erscheint eine Meldung und es wird nicht übertragen.
Wenn Du das nicht haben möchtest, dann folgende Zeilen im Code löschen:

Code:

If lngS = 16 Then
 MsgBox "Übertragfelder voll!"
 Exit Sub
End If

oder Du ersetzt die Zeilen mit folgenden:

Code:

If lngS = 16 Then
 If MsgBox("Übertragfelder voll!" & vbLf & vbLf & "Soll der Bereich geleert werden, um wieder am Anfang einzufügen?", _
           vbYesNo, "FRAGE") = vbYes Then
   Range(Cells(7, 10), Cells(lngZ, lngS)).ClearContents
   lngS = 9
 Else
   Exit Sub
 End If
End If

Dann wird der Zielbereich geleert und es wird wieder am Anfang eingefügt.

[sharky51]

Vielen Dank Attila, einfach cool!!!!!

[sharky51]

Hallo Attila,

ich hätte da noch eine Frage.

Wenn ich im Tabellenblatt weitere Daten eintrage dann arbeitet das Makro auch diese Zellen ab. Das möchte ich natürlich nicht. Siehe angefügte Datei.
Beispielhaft habe ich mal einfach die Einträge runterkopiert.
Der Statistikbereich reicht von J7 - P21. Diesem Bereich habe ich den Namen "Einzel_Statistik" vergeben.

Könntest Du mir bitte zeigen wie Einträge nur in diesem Bereich eingetragen werden können? Der Rest der Tabelle soll unbeeinflusst bleiben.

[atilla]

Hallo Erich,


dann kann der Bereich ja fest angegeben werden. Ich hb das jetzt mal mit Zellbezügen fest gemacht.

Code:

Sub übertragenNeu()
Dim i As Long
Dim lngS As Long
Dim lngA As Long
Dim feld

lngS = Application.Max(9, Cells(7, Columns.Count).End(xlToLeft).Column)
lngA = Application.CountIf(Range("C7:F21"), "x")
feld = Range("C7:F21")

If lngS = 16 Then
MsgBox "Übertragfelder voll!"
Exit Sub
End If

If lngA > 0 Then
For i = 1 To 21 - 6
 If feld(i, 1) <> "" Then
  If feld(i, 4) <> "x" Then
    feld(i, 1) = 0
  End If
 End If
Next i
Range(Cells(7, lngS + 1), Cells(21, lngS + 1)) = feld
End If

End Sub

Du nutzt eine Schaltfläche aus den ActiveX Steuerelementen. Geh dort auf Eigenschaften und änder bei TakeFocusOnClick von True auf False.
Dann wird der Schalter nicht markiert nach Betätigung.

[sharky51]

Attila,

einfach cool...vielen Dank!

Wie das mit dem Namensbereich geht würde mich aber trotzdem interessieren?