Excel vba Richtiges umkopieren

[sharky51]

Hallo Erich,

das war blöd von mir.
Ich hatte den Code mit anderen Zellbzügen entwickelt und habe ihn nachträglich falsch auf Dein eingestelltes Beispiel angepasst.

Folgender Code sollte funktionieren:

Code:

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

lngS = Application.Max(25, Cells(27, Columns.Count).End(xlToLeft).Column)
lngZ = Application.Max(27, Cells(Rows.Count, "U").End(xlUp).Row)
lngA = Application.CountIf(Range(Cells(27, "U"), Cells(lngZ, "V")), "x")
feld = Range(Cells(27, "U"), Cells(lngZ, "V"))

If lngA > 0 Then
ReDim arr(lngA - 1)
For i = 1 To lngZ - 28
  If feld(i, 2) = "x" Then
    arr(k) = feld(i, 1)
    k = k + 1
  End If
Next i

If k > 0 Then
  Cells(27, lngS + 1).Resize(k) = Application.Transpose(arr)
End If

End If
 
End Sub

Hallo Attila,

jetzt funktioniert es schon etwas besser....aber es werden nicht alle Spieler berücksichtigt...schau mal......und es sollte der übertragene Spieler auch in der selben Zeile aufgeführt werden und nicht direkt untereinander.

Hast Du vielleicht noch ne Idee?


Aufstellungsvarianten

	U	V	W	X	Y	Z	AA	AB	AC	AD
26		Auswahl				R1	R2	R3	R4	R5
27	Spieler 1	x				Spieler 1
28	Spieler 2					Spieler 3
29	Spieler 3	x				Spieler 4
30	Spieler 4	x				Spieler 6
31	Spieler 5					Spieler 7
32	Spieler 6	x
33	Spieler 7	x
34	Spieler 8
35	Spieler 9	x
36	Spieler 10	x

Excel-Inn.de

Hajo-Excel.de

XHTML-Tabelle zur Darstellung in Foren, einschl. der neuen Funktionen ab Version 2007

Add-In-Version 21.08 einschl. 64 Bit

Herzlichen Dank!

[atilla]

Hallo Erich,

wnn Du die Zellen in die kopiert wird  so formatierst:

";;"

ginge es einfach mit folgendem Code:

Code:

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

lngS = Application.Max(25, Cells(27, Columns.Count).End(xlToLeft).Column)
lngZ = Application.Max(27, Cells(Rows.Count, "U").End(xlUp).Row)
lngA = Application.CountIf(Range(Cells(27, "U"), Cells(lngZ, "V")), "x")
feld = Range(Cells(27, "U"), Cells(lngZ, "V"))

If lngA > 0 Then
For i = 1 To lngZ - 26
  If feld(i, 2) <> "x" Then
    feld(i, 1) = ""
  End If
Next i
 Range(Cells(27, lngS), Cells(lngZ, lngS)) = feld
End If

End Sub

In den leer ersichtlichen zellen würde dann eine nicht sichtbare 0 stehen.

So sähe es aus:

Arbeitsblatt mit dem Namen 'Tabelle1'
	U	V	W	X	Y	Z
26		Auswahl				R1
27	Spieler 1	x				Spieler 1
28	Spieler 2	x				Spieler 2
29	Spieler 3
30	Spieler 4
31	Spieler 5
32	Spieler 6	x				Spieler 6
33	Spieler 7
34	Spieler 8	x				Spieler 8
35	Spieler 9
36	Spieler 10	x				Spieler 10

Zelle	Format	Wert
Z27	;;	Spieler 1

Diese Tabelle wurde mit Tab2Html (v2.4.1) erstellt. ©Gerd alias Bamberg

Sonst müsste der Code aufwendiger werden.

[sharky51]

Hallo Erich,

wnn Du die Zellen in die kopiert wird  so formatierst:

";;"

ginge es einfach mit folgendem Code:

Code:

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

lngS = Application.Max(25, Cells(27, Columns.Count).End(xlToLeft).Column)
lngZ = Application.Max(27, Cells(Rows.Count, "U").End(xlUp).Row)
lngA = Application.CountIf(Range(Cells(27, "U"), Cells(lngZ, "V")), "x")
feld = Range(Cells(27, "U"), Cells(lngZ, "V"))

If lngA > 0 Then
For i = 1 To lngZ - 26
  If feld(i, 2) <> "x" Then
    feld(i, 1) = ""
  End If
Next i
 Range(Cells(27, lngS), Cells(lngZ, lngS)) = feld
End If

End Sub

In den leer ersichtlichen zellen würde dann eine nicht sichtbare 0 stehen.

So sähe es aus:

Arbeitsblatt mit dem Namen 'Tabelle1'
	U	V	W	X	Y	Z
26		Auswahl				R1
27	Spieler 1	x				Spieler 1
28	Spieler 2	x				Spieler 2
29	Spieler 3
30	Spieler 4
31	Spieler 5
32	Spieler 6	x				Spieler 6
33	Spieler 7
34	Spieler 8	x				Spieler 8
35	Spieler 9
36	Spieler 10	x				Spieler 10

Zelle	Format	Wert
Z27	;;	Spieler 1

Diese Tabelle wurde mit Tab2Html (v2.4.1) erstellt. ©Gerd alias Bamberg

Sonst müsste der Code aufwendiger werden.

Hallo Attila,
gut, aber jetzt werden die ausgewählten Spieler zwar in die richtige Zeile geschrieben aber in die falsche Anfangsspalte...in Spalte X und nicht in Spalte Z. Außerdem wird die Zielspalte immer überschrieben und nicht wir in Deiner vorhergehenden Version in die nächste Spalte z.B. AA geschrieben.

Kuckst Du ....


Aufstellungsvarianten

	U	V	W	X	Y	Z	AA	AB	AC	AD
26		Auswahl				R1	R2	R3	R4	R5
27	Spieler 1	x			Spieler 1
28	Spieler 2
29	Spieler 3
30	Spieler 4	x			Spieler 4
31	Spieler 5
32	Spieler 6	x			Spieler 6
33	Spieler 7
34	Spieler 8	x			Spieler 8
35	Spieler 9	x			Spieler 9
36	Spieler 10	x			Spieler 10

Excel-Inn.de

Hajo-Excel.de

XHTML-Tabelle zur Darstellung in Foren, einschl. der neuen Funktionen ab Version 2007

Add-In-Version 21.08 einschl. 64 Bit

und nach Änderung der Auswahl....


Aufstellungsvarianten

	U	V	W	X	Y	Z	AA	AB	AC	AD
26		Auswahl				R1	R2	R3	R4	R5
27	Spieler 1
28	Spieler 2	x			Spieler 2
29	Spieler 3
30	Spieler 4	x			Spieler 4
31	Spieler 5
32	Spieler 6
33	Spieler 7
34	Spieler 8	x			Spieler 8
35	Spieler 9
36	Spieler 10	x			Spieler 10

Excel-Inn.de

Hajo-Excel.de

XHTML-Tabelle zur Darstellung in Foren, einschl. der neuen Funktionen ab Version 2007

Add-In-Version 21.08 einschl. 64 Bit

[atilla]

Hallo Erich,


schwere Geburt.

Änder diese Zeile so um:

Range(Cells(27, lngS + 1), Cells(lngZ, lngS + 1)) = feld

Das rot markierte ist hinzugekommen.

[sharky51]

Hallo Erich,


schwere Geburt.

Änder diese Zeile so um:

Range(Cells(27, lngS + 1), Cells(lngZ, lngS + 1)) = feld

Das rot markierte ist hinzugekommen.

Hallo Attila,

danke....Asche auf mein Haupt...da hätte ich selbst drauf kommen können.
Aber das weiterschalten ab der Spalte Z ist damit noch nicht behoben.

[atilla]

Hallo Erich,

müsste aber.

Da ich nicht genau weiß, welchen Code Du verändert hast, hier noch einmal der gesamte Code:

Code:

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

lngS = Application.Max(25, Cells(27, Columns.Count).End(xlToLeft).Column)
lngZ = Application.Max(27, Cells(Rows.Count, "U").End(xlUp).Row)
lngA = Application.CountIf(Range(Cells(27, "U"), Cells(lngZ, "V")), "x")
feld = Range(Cells(27, "U"), Cells(lngZ, "V"))

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

End Sub

Und unten die Beispieldatei:


  Mappe1Sharky51.xlsm (Größe: 17,65 KB / Downloads: 3)

[sharky51]

Hallo Erich,

müsste aber.

Da ich nicht genau weiß, welchen Code Du verändert hast, hier noch einmal der gesamte Code:

Code:

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

lngS = Application.Max(25, Cells(27, Columns.Count).End(xlToLeft).Column)
lngZ = Application.Max(27, Cells(Rows.Count, "U").End(xlUp).Row)
lngA = Application.CountIf(Range(Cells(27, "U"), Cells(lngZ, "V")), "x")
feld = Range(Cells(27, "U"), Cells(lngZ, "V"))

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

End Sub

Und unten die Beispieldatei:

Super Attila,

jetzt funktioniert es perfekt....vielen herzlichen Dank!

[sharky51]

IHR SEID SCHON WIRKLICH ALLE KLASSE!!!!!!!!!!!

[Steffl]

Hallo Erich,

du brauchst nicht in jeder Antwort den Beitrag vom Vorredner komplett zitieren. Die wissen meistens noch was sie vorher geschrieben haben.

[sharky51]

Hallo Attila,

ich muss nochmals nachhaken.
Deine Beispieldatei funktioniert bestens.
Nur hätte ich gerne die ganzen Daten an einer anderen Stelle im Tabellenblatt.
Leider schaffe ich es nicht das Ganze richtig anzupassen damit das an der Stelle (Zeilen/Spalten) auch funktioniert.

Wärst Du so nett mir den Code auf das eingefügte Tabellenblatt anzupassen...der Lerneffekt für mich wäre auch gleich da?


  Mappe1Sharky51_V1.xlsm (Größe: 39,5 KB / Downloads: 2)