Inhaltzellen kopieren?

Hallo zusammen,
ich bitte um Eure Hilfe!
Folgendes:
In Tabelle1 Zellen A1:A34 stehen die Arbeitszeiten wie folgt:
06:00 - 18:00 TO
06:00 - 18:00 T7
18:00 - 06:00 Au
nun brauche ich einen VBA-Code, der die Arbeitszeiten mit den oben genannten Zeichen (TO/T7/Au)sucht und in den anderen Tabellen kopiert.
Beispiel:
Wenn in Tabelle1 A1:A34 die Dienste mit den Zeichen TO vorhanden sind, sollen diese in die Tabelle2 an den gleichen stellen, wie in Tabelle1 A1:A34 kopiert werden .
Wenn in Tabelle1 A1:A34 die Dienste mit den Zeichen T7 vorhanden sind, sollen diese in die Tabelle3 an den gleichen stellen, wie in Tabelle1 A1:A34 kopiert werden .
usw.............
vielen Dank für eine kurze Rückmeldung!
Mit freundlichen Grüßen
Ahmadian

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub kopieren3() Dim RnG As Range, MyTab As Worksheet For Each RnG In Tabelle1.Range("A1:AA34") If RnG "" Then If Right(RnG, 2) = "TO" Then Set MyTab = Tabelle2 If Right(RnG, 2) = "T7" Then Set MyTab = Tabelle3 If Right(RnG, 2) = "Au" Then Set MyTab = Tabelle4 MyTab.Range(RnG.Address) = RnG End If Next Set MyTab = Nothing End Sub

Sub kopieren2() Dim x&, j&, MyTab As Worksheet For j = 1 To 27 For x = 1 To 34 With Tabelle1 If .Cells(x, j) "" Then If Right(.Cells(x, j), 2) = "TO" Then Set MyTab = Tabelle2 If Right(.Cells(x, j), 2) = "T7" Then Set MyTab = Tabelle3 If Right(.Cells(x, j), 2) = "Au" Then Set MyTab = Tabelle4 MyTab.Cells(x, j) = .Cells(x, j) End If End With Next Next Set MyTab = Nothing End Sub

Sub kopiere() Dim x&, y&, MyTab As Worksheet For y = 1 To 27 ' Spalten 1- 27 , also A bis AA For x = 1 To 34 ' Zeilen 1 - 34 With Tabelle1 If .Cells(x, y) "" Then If Right(.Cells(x, y), 2) = "TO" Then Set MyTab = Tabelle2 If Right(.Cells(x, y), 2) = "T7" Then Set MyTab = Tabelle3 If Right(.Cells(x, y), 2) = "Au" Then Set MyTab = Tabelle4 MyTab.Cells(x, y) = .Cells(x, y) End If End With Next Next End Sub

Option Explicit Sub kopiere2() Dim zz As Long, ss As Long, wksZ As Worksheet With Tabelle1 For ss = 1 To 27 For zz = 1 To 34 If .Cells(zz, ss) "" Then Select Case Right(.Cells(zz, ss), 2) Case "TO": Set wksZ = Tabelle2 Case "T7": Set wksZ = Tabelle3 Case "Au": Set wksZ = Tabelle4 ' Case Else: MsgBox "TO - T7 - AU nicht gefunden" ' evtl. End Select If Not wksZ Is Nothing Then wksZ.Cells(zz, ss) = .Cells(zz, ss) Set wksZ = Nothing End If Next Next End With End Sub

Option Explicit Sub kopiere2() Dim zz As Long, ss As Long, wksZ As Worksheet With Tabelle1 For ss = 1 To 27 For zz = 1 To 34 Select Case Right(.Cells(zz, ss), 2) Case "" ' Zelle leer, nichts zu tun Case "TO": Set wksZ = Tabelle2 Case "T7": Set wksZ = Tabelle3 Case "Au": Set wksZ = Tabelle4 Case Else: MsgBox "TO / T7 / AU nicht gefunden in " & _ .Cells(zz, ss).Address(0, 0) End Select If Not wksZ Is Nothing Then wksZ.Cells(zz, ss) = .Cells(zz, ss) Set wksZ = Nothing End If Next Next End With End Sub

Hallo Erich
Das mit dem Fehler war mir noch garnicht aufgefallen, Danke.
Und mit dem With vor den Schleifen, hast Du vollkommen Recht :-)
Ich habs für mich jetzt mal so geändert:

Sub kopieren4()
Dim x&, j&, MyTab As Worksheet
With Tabelle1
For j = 1 To 27
For x = 1 To 34
If .Cells(x, j)  "" And (Right(.Cells(x, j), 2) = "TO" Or Right(.Cells(x, j), 2) = "T7"  _
Or Right(.Cells(x, j), 2) = "Au") Then
If Right(.Cells(x, j), 2) = "TO" Then Set MyTab = Tabelle2
If Right(.Cells(x, j), 2) = "T7" Then Set MyTab = Tabelle3
If Right(.Cells(x, j), 2) = "Au" Then Set MyTab = Tabelle4
MyTab.Cells(x, j) = .Cells(x, j)
End If
Next
Next
End With
Set MyTab = Nothing
End Sub

Sub kopieren5()
Dim RnG As Range, MyTab As Worksheet
For Each RnG In Tabelle1.Range("A1:AA34")
If RnG  "" And (Right(RnG, 2) = "TO" Or Right(RnG, 2) = "T7" Or Right(RnG, 2) = "Au")  _
Then
If Right(RnG, 2) = "TO" Then Set MyTab = Tabelle2
If Right(RnG, 2) = "T7" Then Set MyTab = Tabelle3
If Right(RnG, 2) = "Au" Then Set MyTab = Tabelle4
MyTab.Range(RnG.Address) = RnG
End If
Next
Set MyTab = Nothing
End Sub

scheint ja so auch zu klappen.
und Danke nochmal für die Infos!
Userbild

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Inhaltzellen kopieren?

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread