Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Kopieren in mehrere Tabellenblätter

Kopieren in mehrere Tabellenblätter
chris58
Hallo !
Ich habe eine Frage an die Spezialisten. Ich habe diesen Code zum kopieren auf ein Tabellenblatt hier gefunden. Ich will fragen, ob es möglich ist, diesen code dahingehend zu erweitern, daß ich mit diesem Code gleichzeitig auf mehrere Tabellenblätter kopieren kann.
1. In der Spalte I steht die Auswahl welche für das kopieren zuständig ist mit
WVK = Tabellenblatt Warenverkauf
A = Tabellenblatt Ausgaben und Einnahmen
F = Tabellenblatt Fremdgutscheine
WEK = Tabellenblatt Wareneinkauf
Die Spalte I sollte nicht auf die einzelnen Tabellenblätter mitkopiert werden.
Danke für die Hilfe
chris
Option Explicit
Public Sub AuswaehlenKopieren()
Dim WkSh_Q As Worksheet
Dim WkSh_Z As Worksheet
Dim rZelle As Range
Dim sFundst As String
Dim sSuchbegriff As String
Dim lZeile_Z As Long
sSuchbegriff = "WVK" ' der zu suchende Begriff
lZeile_Z = 1 ' die erste Ausgabezeile -1
Application.ScreenUpdating = False
Set WkSh_Q = Worksheets("Saldenliste") ' den Tabellenblattnamen ggf. anpassen !!!
Set WkSh_Z = Worksheets("Warenverkauf") ' den Tabellenblattnamen ggf. anpassen !!!
With WkSh_Q.Columns(9)
' wenn der gesamte Suchbegriff gefunden werden soll muss es
' xlWhole anstelle von xlPart heißen.
Set rZelle = .Find(sSuchbegriff, LookAt:=xlPart, LookIn:=xlValues)
If Not rZelle Is Nothing Then
sFundst = rZelle.Address
Do
lZeile_Z = lZeile_Z + 1
WkSh_Q.Rows(rZelle.Row).Copy Destination:=WkSh_Z.Rows(lZeile_Z)
Set rZelle = .FindNext(rZelle)
Loop While Not rZelle Is Nothing And rZelle.Address sFundst
Else
MsgBox "Zum gesuchen Begriff """ & sSuchbegriff & _
""" wurde kein Eintrag gefunden.", _
48, " Hinweis für " & Application.UserName
End If
End With
AW: Kopieren in mehrere Tabellenblätter
24.06.2011 06:44:12
Hajo_Zi
Hallo Chris,
Option Explicit
Sub chris()
'Ersetze
'WkSh_Q.Rows(rZelle.Row).Copy Destination:=WkSh_Z.Rows(lZeile_Z)
' durch
WkSh_Q.Range(Cells(rZelle.Row, 1), Cells(rZelle.Row, 8)).Copy Destination:=WkSh_Z.Cells( _
lZeile_Z, 1)
WkSh_Q.Range(Cells(rZelle.Row, 10), Cells(rZelle.Row, 256)).Copy Destination:=WkSh_Z.Cells( _
lZeile_Z, 9)
WkSh_Q.Range(Cells(rZelle.Row, 1), Cells(rZelle.Row, 8)).Copy Destination:=Worksheets(" _
Tabele1").Cells(lZeile_Z, 1)
WkSh_Q.Range(Cells(rZelle.Row, 10), Cells(rZelle.Row, 256)).Copy Destination:=Worksheets(" _
Tabele1").Cells(lZeile_Z, 9)
End Sub


Anzeige
AW: Kopieren in mehrere Tabellenblätter
24.06.2011 08:13:17
chris58
Hallo !
Ich habe das nun so ersetzt, doch da kommt der Fehler "Kann im Haltemodus nicht aus geführt werden"
Hoffe ich habe das richtig ersetzt
Option Explicit
Public Sub AuswaehlenKopieren()
Dim WkSh_Q As Worksheet
Dim WkSh_Z As Worksheet
Dim rZelle As Range
Dim sFundst As String
Dim sSuchbegriff As String
Dim lZeile_Z As Long
sSuchbegriff = "WVK" ' der zu suchende Begriff
lZeile_Z = 1 ' die erste Ausgabezeile -1
Application.ScreenUpdating = False
Set WkSh_Q = Worksheets("Saldenliste") ' den Tabellenblattnamen ggf. anpassen !!!
Set WkSh_Z = Worksheets("Warenverkauf") ' den Tabellenblattnamen ggf. anpassen !!!
With WkSh_Q.Columns(9)
' wenn der gesamte Suchbegriff gefunden werden soll muss es
' xlWhole anstelle von xlPart heißen.
Set rZelle = .Find(sSuchbegriff, LookAt:=xlPart, LookIn:=xlValues)
If Not rZelle Is Nothing Then
sFundst = rZelle.Address
Do
lZeile_Z = lZeile_Z + 1
WkSh_Q.Range(Cells(rZelle.Row, 1), Cells(rZelle.Row, 8)).Copy Destination:=WkSh_Z.Cells( _
lZeile_Z, 1)
WkSh_Q.Range(Cells(rZelle.Row, 10), Cells(rZelle.Row, 256)).Copy Destination:=WkSh_Z.Cells( _
lZeile_Z, 9)
WkSh_Q.Range(Cells(rZelle.Row, 1), Cells(rZelle.Row, 8)).Copy Destination:=Worksheets(" _
Tabele1 ").Cells(lZeile_Z, 1)"
WkSh_Q.Range(Cells(rZelle.Row, 10), Cells(rZelle.Row, 256)).Copy Destination:=Worksheets(" _
Tabele1 ").Cells(lZeile_Z, 9)"
Set rZelle = .FindNext(rZelle)
Loop While Not rZelle Is Nothing And rZelle.Address sFundst
Else
MsgBox "Zum gesuchen Begriff """ & sSuchbegriff & _
""" wurde kein Eintrag gefunden.", _
48, " Hinweis für " & Application.UserName
End If
End With
Anzeige
AW: Kopieren in mehrere Tabellenblätter
24.06.2011 15:30:34
Hajo_Zi
Hallo Chris,
Du hast eine Tabelle mit dem Namen "Tabele1 "?
Gruß Hajo
AW: Kopieren in mehrere Tabellenblätter
24.06.2011 08:32:43
chris58
Hallo !
Beim kopieren ging was schief. Habe nicht den ganzen Code kopiert......mein Fehler
Hier der gesamte Code und der Austausch
Option Explicit
Public Sub AuswaehlenKopieren()
Dim WkSh_Q As Worksheet
Dim WkSh_Z As Worksheet
Dim rZelle As Range
Dim sFundst As String
Dim sSuchbegriff As String
Dim lZeile_Z As Long
sSuchbegriff = "WVK" ' der zu suchende Begriff
lZeile_Z = 1 ' die erste Ausgabezeile -1
Application.ScreenUpdating = False
Set WkSh_Q = Worksheets("Saldenliste") ' den Tabellenblattnamen ggf. anpassen !!!
Set WkSh_Z = Worksheets("Warenverkauf") ' den Tabellenblattnamen ggf. anpassen !!!
With WkSh_Q.Columns(9)
' wenn der gesamte Suchbegriff gefunden werden soll muss es
' xlWhole anstelle von xlPart heißen.
Set rZelle = .Find(sSuchbegriff, LookAt:=xlPart, LookIn:=xlValues)
If Not rZelle Is Nothing Then
sFundst = rZelle.Address
Do
lZeile_Z = lZeile_Z + 1
WkSh_Q.Range(Cells(rZelle.Row, 1), Cells(rZelle.Row, 8)).Copy Destination:=WkSh_Z.Cells( _
lZeile_Z, 1)
WkSh_Q.Range(Cells(rZelle.Row, 10), Cells(rZelle.Row, 256)).Copy Destination:=WkSh_Z.Cells(  _
_
lZeile_Z, 9)
WkSh_Q.Range(Cells(rZelle.Row, 1), Cells(rZelle.Row, 8)).Copy Destination:=Worksheets(" _
Tabele1").Cells(lZeile_Z, 1)
WkSh_Q.Range(Cells(rZelle.Row, 10), Cells(rZelle.Row, 256)).Copy Destination:=Worksheets("  _
_
Tabele1").Cells(lZeile_Z, 9)
Set rZelle = .FindNext(rZelle)
Loop While Not rZelle Is Nothing And rZelle.Address  sFundst
Else
MsgBox "Zum gesuchen Begriff """ & sSuchbegriff & _
""" wurde kein Eintrag gefunden.", _
48, " Hinweis für " & Application.UserName
End If
End With
Application.ScreenUpdating = True
End Sub

Anzeige
AW: Kopieren in mehrere Tabellenblätter
24.06.2011 08:38:48
chris58
Hallo !
Ich habe das Beispiel hochgeladen. Mir ist noch aufgefallen, daß beim kopieren auch die Formeln mitkopiert werden, sodaß ich dann keine Berechnung machen kann, da es zu einem Zirkelbezug wird. Kann der VBA nur die nackten Zahlen kopieren und die Formeln weglassen ?
Danke vielmals
chris
https://www.herber.de/bbs/user/75436.xls
AW: Kopieren in mehrere Tabellenblätter
24.06.2011 15:28:49
Hajo_Zi
Hallo Chris,
was soll mir Dein Beitrag sagen?
Gruß Hajo
AW: Kopieren in mehrere Tabellenblätter
24.06.2011 15:43:58
chris58
Hallo !
Ich habe nicht den ganzen Code kopiert, dabei ging was schief. Ich habe die Zeilen die du mir freundlicherweise überlassen hast, in den Code eingefügt, doch da kam immer ein Fehler. Nun habe ich einen kleinen Auschnitt der Datei raufgeladen. Würdest du mir den Code da reinstellen - Bitte......
Ich weiß nicht, wo ich deine Zeilen reinkopieren soll, habe alle möglichen Varianten versucht, doch ohne Erfolg.
mfg chris
Anzeige
AW: Kopieren in mehrere Tabellenblätter
24.06.2011 15:59:46
Hajo_Zi
Hallo Chris,
Du hast meinen Hinweis aus dem andern Beitrag zum Tabellennamen beachtet?
Das ist der Vorteil, wenn man die Disskussion an mehren Stellen führt.
Gruß Hajo
AW: Kopieren in mehrere Tabellenblätter
24.06.2011 16:14:08
chris58
Hallo !
Ich habe den Code geändert auf "Tabelle1". Doch es kommt immer ein Fehler.........kann im Haltemodus nicht ausgeführt werden..........
Kenn mich jetzt nicht mehr aus, was ich ändern soll
mfg chris
Option Explicit
Public Sub AuswaehlenKopieren()
Dim WkSh_Q As Worksheet
Dim WkSh_Z As Worksheet
Dim rZelle As Range
Dim sFundst As String
Dim sSuchbegriff As String
Dim lZeile_Z As Long
sSuchbegriff = "WVK" ' der zu suchende Begriff
lZeile_Z = 1 ' die erste Ausgabezeile -1
Application.ScreenUpdating = False
Set WkSh_Q = Worksheets("Saldenliste") ' den Tabellenblattnamen ggf. anpassen !!!
Set WkSh_Z = Worksheets("Warenverkauf") ' den Tabellenblattnamen ggf. anpassen !!!
With WkSh_Q.Columns(9)
' wenn der gesamte Suchbegriff gefunden werden soll muss es
' xlWhole anstelle von xlPart heißen.
Set rZelle = .Find(sSuchbegriff, LookAt:=xlPart, LookIn:=xlValues)
If Not rZelle Is Nothing Then
sFundst = rZelle.Address
Do
lZeile_Z = lZeile_Z + 1
WkSh_Q.Range(Cells(rZelle.Row, 1), Cells(rZelle.Row, 8)).Copy Destination:=WkSh_Z.Cells( _
lZeile_Z, 1)
WkSh_Q.Range(Cells(rZelle.Row, 10), Cells(rZelle.Row, 256)).Copy Destination:=WkSh_Z. _
Cells( _
lZeile_Z, 9)
' ab hier kommt der Fehler kann im Haltemodus nicht ausgeführt werden
WkSh_Q.Range(Cells(rZelle.Row, 1), Cells(rZelle.Row, 8)).Copy Destination:= _
Worksheets(" _
Tabelle1").Cells(lZeile_Z, 1)
WkSh_Q.Range(Cells(rZelle.Row, 10), Cells(rZelle.Row, 256)).Copy Destination:= _
Worksheets(" _
Tabelle1").Cells(lZeile_Z, 9)
Set rZelle = .FindNext(rZelle)
Loop While Not rZelle Is Nothing And rZelle.Address  sFundst
Else
MsgBox "Zum gesuchen Begriff """ & sSuchbegriff & _
""" wurde kein Eintrag gefunden.", _
48, " Hinweis für " & Application.UserName
End If
End With
Application.ScreenUpdating = True
End Sub

Anzeige
AW: Kopieren in mehrere Tabellenblätter
24.06.2011 17:22:48
Hajo_Zi
Halo Chris,
entgegen meiner Norm habe ich die Datei nachgebaut und folgender Code läuft Fehlerfrei.
Option Explicit
Public Sub AuswaehlenKopieren()
Dim WkSh_Q As Worksheet
Dim WkSh_Z As Worksheet
Dim rZelle As Range
Dim sFundst As String
Dim sSuchbegriff As String
Dim lZeile_Z As Long
sSuchbegriff = "WVK" ' der zu suchende Begriff
lZeile_Z = 1 ' die erste Ausgabezeile -1
Application.ScreenUpdating = False
Set WkSh_Q = Worksheets("Saldenliste") ' den Tabellenblattnamen ggf. anpassen !!!
Set WkSh_Z = Worksheets("Warenverkauf") ' den Tabellenblattnamen ggf. anpassen !!!
With WkSh_Q.Columns(9)
' wenn der gesamte Suchbegriff gefunden werden soll muss es
' xlWhole anstelle von xlPart heißen.
Set rZelle = .Find(sSuchbegriff, LookAt:=xlPart, LookIn:=xlValues)
If Not rZelle Is Nothing Then
sFundst = rZelle.Address
Do
lZeile_Z = lZeile_Z + 1
WkSh_Q.Range(Cells(rZelle.Row, 1), Cells(rZelle.Row, 8)).Copy _
Destination:=WkSh_Z.Cells(lZeile_Z, 1)
WkSh_Q.Range(Cells(rZelle.Row, 10), Cells(rZelle.Row, 256)).Copy _
Destination:=WkSh_Z.Cells(lZeile_Z, 9)
' ab hier kommt der Fehler kann im Haltemodus nicht ausgeführt werden
WkSh_Q.Range(Cells(rZelle.Row, 1), Cells(rZelle.Row, 8)).Copy _
Destination:=Worksheets("Tabelle1").Cells(lZeile_Z, 1)
WkSh_Q.Range(Cells(rZelle.Row, 10), Cells(rZelle.Row, 256)).Copy _
Destination:=Worksheets("Tabelle1").Cells(lZeile_Z, 9)
Set rZelle = .FindNext(rZelle)
Loop While Not rZelle Is Nothing And rZelle.Address  sFundst
Else
MsgBox "Zum gesuchen Begriff """ & sSuchbegriff & _
""" wurde kein Eintrag gefunden.", _
48, " Hinweis für " & Application.UserName
End If
End With
Application.ScreenUpdating = True
End Sub

Gruß Hajo
Anzeige
AW: Kopieren in mehrere Tabellenblätter
24.06.2011 17:40:29
chris58
Danke für die Mühe, doch der Code bringt das gleiche wie vorher auch. Er kopiert die Daten in das Tabellenblatt "Warenverkauf" und die gleichen Daten in das Tabellenblatt "Wareneinkauf". Die Tabellenblätter "Fremdgutscheine" und "Ausgaben und Einnahmen" bleiben leer.
Danke jedenfalls für deine Mühe, ich werde mir das überlegen, was ich machen kann, um das nicht Zeile für Zeile zu kopieren.
Noch ein schönes Wochenende
chris
https://www.herber.de/bbs/user/75439.xls
AW: Kopieren in mehrere Tabellenblätter
24.06.2011 18:48:51
Hajo_Zi
Hallo Chris,
von den Tabellen "Fremdgutscheine" und "Ausgaben und Einnahmen" steht nichts im Code.
Gruß Hajo
Anzeige
AW: Kopieren in mehrere Tabellenblätter
24.06.2011 20:23:10
chris58
Holla Hajo !
Ich habe die Datei dazugepackt, da sind alle Tabellenblätter drauf. Der Code sollte von selbst in jedes Tabellenblatt die mit der Bedingung "WVK", "WEK", "F" und "A" in die vorgesehenen Tabellblätter verfrachten. Doch das ist für mich einfach nicht bewältigbar. Kenn mich ja mit dem VBA Codes nur wenig aus. Danke jedenfalls für deine Mithilfe, doch ich werde es lassen und weiter mittels Copy&Past das ganze machen.
lg chris
AW: Kopieren in mehrere Tabellenblätter
24.06.2011 20:25:42
KlausF
Hallo chris,
der folgende Code leert aber nicht evtl vorhandene Daten in den Zielblättern.
Und noch etwas: lösche den Blanc hinter dem Sheetnamen "Ausgaben und Einnahmen "
sonst gibt es einen Codefehler!!
Gruß
Klaus
Option Explicit
Sub DatenAufteilen()
Dim SOURCE As Worksheet
Dim ZIEL As Worksheet
Set SOURCE = Worksheets("Saldenliste")
Dim ENDE As Long
Dim FREI As Long
ENDE = SOURCE.Range("I65536").End(xlUp).Row
Dim SUCHWORT As String
Dim i As Integer
For i = 4 To ENDE
SUCHWORT = Range("I" & i).Value
If SUCHWORT  "" Then
Select Case SUCHWORT
Case "WVK"
Set ZIEL = Worksheets("Warenverkauf")
FREI = ZIEL.Range("A2:A65536").Find(What:="", Lookat:=xlWhole, LookIn:=xlValues). _
Row
SOURCE.Range("A" & i & ":H" & i).Copy Destination:=ZIEL.Range("A" & FREI & ":H" &  _
FREI)
Case "A"
Set ZIEL = Worksheets("Ausgaben und Einnahmen")
FREI = ZIEL.Range("A2:A65536").Find(What:="", Lookat:=xlWhole, LookIn:=xlValues). _
Row
SOURCE.Range("A" & i & ":H" & i).Copy Destination:=ZIEL.Range("A" & FREI & ":H" &  _
FREI)
Case "F"
Set ZIEL = Worksheets("Fremdgutscheine")
FREI = ZIEL.Range("A2:A65536").Find(What:="", Lookat:=xlWhole, LookIn:=xlValues). _
Row
SOURCE.Range("A" & i & ":H" & i).Copy Destination:=ZIEL.Range("A" & FREI & ":H" &  _
FREI)
Case "WEK"
Set ZIEL = Worksheets("Wareneinkauf")
FREI = ZIEL.Range("A2:A65536").Find(What:="", Lookat:=xlWhole, LookIn:=xlValues). _
Row
SOURCE.Range("A" & i & ":H" & i).Copy Destination:=ZIEL.Range("A" & FREI & ":H" &  _
FREI)
Case Else
End Select
End If
Next i
Set ZIEL = Nothing
Set SOURCE = Nothing
End Sub

Anzeige
AW: Kopieren in mehrere Tabellenblätter
24.06.2011 20:49:32
chris58
Danke, das funktioniert wunderbar, danke
bin begeistert, ein wunderbares Wochende wünsche ich Euch allen
Danke chris

308 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige