Werte in mehreren Arbeitblättern kopieren

Ernst · 2019-11-08T13:54:33+00:00

Hallo liebe Forum Freunde, Folgendes Problem (Wissenslücken) habe ich in der Programmierung, was ich so noch nicht umsetzen kann, ich hoffe, dass ihr mir helfen könnt. Ich habe eine Arbeitsmappe WerteKopieren_Test mit 7 Tabellenblättern. In dem Tab Tab1999 stehen in der Spalte A die Kegler Nummern, in der Spalte B Namen und in der Spalte C-D stehen die Kegler Werte. In dem Tab Tabelle2 stehen in der Spalte A die Kegler Nummern, in der Spalte B Namen und in der Spalte C-D stehen die Kegler Werte. Programmablauf: Zurzeit funktioniert das Marko wie folgt: In der Tab1999 werden in der Spalte A die Nummern gesucht. Wird eine Nummer gefunden so wird in der Tabelle2 geprüft ob dort die gleiche Nummer vorhanden ist. Wenn ja, wird der Kegler Wert aus der jeweiligen Spalte, im ersten Lauf, die Spalte C der Tabelle2 ermittelt und in der Tab1999 in der Spalte C kopiert. Das funktioniert auch. Wenn ich die anderen Felder kopieren will, muss ich jeweils manuell in der Anweisung den Befehl Nummer.Offset(0, 2).Value = Treffer.Offset(0, 2).Value um 1 erhöhen Nummer.Offset(0, 3).Value = Treffer.Offset(0, 3).Value bis alle Spalten gefüllt sind. Das funktioniert auch. Meine Frage an euch, kann man das im Programm so einstellen, dass das automatisch erfolgt? Wenn ja, bitte ich euch um eure Hilfe. Ferner frage ich euch, wie der Programmablauf wäre, wenn ich den jeweiligen Wert direkt in die jeweiligen Arbeitsblätter und der entsprechenden Spalte kopieren würde. Ich hoffe, ihr könnt mir helfen.

Hallo Ernst
okay, das Makro "umdrehen" war keine grosse Sache. Anbei der geaenderte Code zum austauschen.
Getauscht werden muss nur das 1. Makro, von Tabelle2 in Tab1999 kopieren. Das andere ist richtig.
Frage: - im Augenblick lösche ich die alten Daten in Tab1999, weil ja nicht mehr alle aktuell sind. Ist das richtig, oder sollen nur die Werte pro Person ausgetauscht werden? Wenn nicht gelöscht werden soll brauchst du nur den Befehl hinter dem Kommentar mit "**" löschen. Es ist diese Code Zeile:
.Range("C2:G" & ZeileMax).ClearContents
Mir ist aufgefallen das bei mir in Tab1999 die Überschrift in Spalte E nicht stimmt. Da steht Wehrt statt Feicks wie in Tabelle2. Der Reiter hat den Namen "Fricks" statt "Feicks". Würde mich freuen wenn jetzt alles perfekt klappt.
mfg Piet

Option Explicit      '10.11.2019   Piet   für Herber Forum
'Makro1 übertraegt Daten aus Tabelle 1999 in Tabelle 2
Sub InTabelle2_WerteKopieren()
Dim ZeileMax As Long
Dim Treffer As Range
Dim ZeileMax2 As Long
Dim KKNr As Range        'KKNr als Range
Dim i As Integer         'For Next Spalten C-G
With Tab1999
'Zeile max in Spalte A suchen über Cells
ZeileMax = .Cells(Rows.Count, 1).End(xlUp).Row
'** Tab1999 alten Datenbereich löschen
.Range("C2:G" & ZeileMax).ClearContents
Application.ScreenUpdating = False
'Schleife um alle Kegler Nummern zu suchen
For Each KKNr In .Range("A2:A" & ZeileMax)
Set Treffer = Tabelle2.Columns("A").Find(what:=KKNr, lookat:=xlWhole)
If Not Treffer Is Nothing Then
'Kegler Name zusaetzlich mit vergleichen
If Treffer.Offset(0, 1).Value = KKNr.Offset(0, 1).Value Then
'Übertrage Spalte C-G in Tabelle2 wenn Wert  ""
For i = 2 To 6
If KKNr  "" Then KKNr.Offset(0, i).Value = Treffer.Offset(0, i).Value
Next i
Else  'anzeigen welcher Kegler nicht mehr dabei ist
'MsgBox KKNr & " / " & KKNr.Offset(0, 1) & " - Name in Tabelle2 nicht gefunden!"
End If
End If
Next KKNr
MsgBox "Tabelle2 fertig"
End With
End Sub

Hallo Ernst,
ich hab in deiner ursprünglichen Beispiel-Datei mal 2 Makros erstellt.
Probiere mal, ob die das gewünschte Ergebnis liefern.
LG
Franz

Sub WerteKopieren()
'übertragen von Tabelle2 (Tabelle2) nach Tab1999 (Tab 1999)
Dim Zeile As Long
Dim ZeileMax As Long
Dim Treffer As Range
Dim Nummer As Range
Dim Namen As Range
Dim lngOffset As Long
Dim wksZiel As Worksheet
Dim wksQuelle As Worksheet
Dim StatusCalc As Long
Set wksZiel = Tab1999
Set wksQuelle = Tabelle2
With Application
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With wksZiel
ZeileMax = .Range("A" & .Rows.Count).End(xlUp).Row
'Altdaten löschen in Spalten C bis G
.Range(.Cells(1, 3), .Cells(ZeileMax, 7)).ClearContents
'Keglernamen kopieren in Zeile 1
With wksQuelle
.Range(.Cells(1, 3), .Cells(1, 7)).Copy
End With
.Range(.Cells(1, 3), .Cells(1, 7)).PasteSpecial Paste:=xlPasteValues
For Zeile = 2 To ZeileMax
Set Nummer = .Range("A" & Zeile)
If Not Nummer Is Nothing Then
Set Treffer = wksQuelle.Columns("A").Find(what:=Nummer.Value, _
LookIn:=xlValues, lookat:=xlWhole)
If Not Treffer Is Nothing Then
'Werte aus Spalten C bis G
For lngOffset = 2 To 6
Nummer.Offset(0, lngOffset).Value = _
Treffer.Offset(0, lngOffset).Value
Next lngOffset
End If
End If
Next Zeile
With Application
.Calculate
.Calculation = StatusCalc
.ScreenUpdating = True
End With
End With
End Sub
Sub WerteKopieren_Tab1999_nach_Name()
'übertragen von Tab1999 (Tab 1999) nach Tabellenblätter mit Namen
Dim Zeile As Long
Dim ZeileMax As Long
Dim Treffer As Range
Dim Nummer As Range
Dim Namen As Range
Dim lngSpalte As Long
Dim iTab As Integer
Dim wksZiel As Worksheet
Dim wksQuelle As Worksheet
Dim bolName As Boolean
Dim StatusCalc As Long
Set wksQuelle = Tab1999
With Application
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
For lngSpalte = 3 To 7 'Spalten mit den Namen in Zeile 1 des Quellblatts
bolName = False
For iTab = 3 To ThisWorkbook.Sheets.Count
Set wksZiel = ThisWorkbook.Sheets(iTab)
With wksZiel
'Prüfen, ob Name mit Name in Quelle übereinstimmt
If .Range("C1") = wksQuelle.Cells(1, lngSpalte).Value Then
bolName = True
ZeileMax = .Range("A" & .Rows.Count).End(xlUp).Row
'Altdaten löschen in Spalte C ab Zeile 2
.Range(.Cells(2, 3), .Cells(ZeileMax, 3)).ClearContents
For Zeile = 2 To ZeileMax
Set Nummer = .Range("A" & Zeile)
If Not Nummer Is Nothing Then
Set Treffer = wksQuelle.Columns("A").Find(what:=Nummer.Value, _
LookIn:=xlValues, lookat:=xlWhole)
If Not Treffer Is Nothing Then
Nummer.Offset(0, 2).Value = _
wksQuelle.Cells(Treffer.Row, lngSpalte).Value
End If
End If
Next Zeile
End If
End With
Next iTab
If bolName = False Then
MsgBox "Kein Blatt mit Name """ _
& wksQuelle.Cells(1, lngSpalte).Value & """ in C1 vorhanden!"
End If
Next lngSpalte
With Application
.Calculate
.Calculation = StatusCalc
.ScreenUpdating = True
End With
End Sub

	A	B	C	D	E	F	G	H	I
1	KK Nr.	Name	Wehrt	Radem.	Feicks	Stubbe Hinten	Stubbe Vorne	Gesamt	Kegelclub
114	33	Maack, Hans-Peter	470	460	477	475	479	2.361	He wackelt
115	55	Maack, Martin	467	448	472	465	473	2.325	He wackelt
189	114	Stubbe, Wilhelm 1	0	0	0	0	0	0	Rube Gesell'n
195	168	Tenzer, Wolfgang	0	0	0	0	0	0	Rube Gesell'n
200	114	Unshelm, Rolf	475	334	470	462	476	2.217	Rube Gesell'n
205	168	Voß, Ernst	449	431	0	0	0	880	Rube Gesell'n

	A	B	C	D	E	F	G	H	I
1	Kegler Nummer	Keglername	Wehrt	Radem.	Feicks	Stubbe Hinten	Stubbe Vorne	Gesamt	Kegelclub
129	55	Maack, Hans-Peter	467	448	472	465	473	2325	He wackelt
130	33	Maack, Martin	470	460	477	475	479	2361	He wackelt
215	22	Stubbe, Wilhelm 1						0	Rube Gesell'n
221	81	Tenzer, Wolfgang						0	Rube Gesell'n
226	114	Unshelm, Rolf	0	0	0	0	0	0	Rube Gesell'n
231	168	Voß, Ernst	0	0	0	0	0	0	Rube Gesell'n

Werte in mehreren Arbeitblättern kopieren

Forumthread: Werte in mehreren Arbeitblättern kopieren

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Werte in mehreren Arbeitblättern kopieren

Forumthread: Werte in mehreren Arbeitblättern kopieren

17 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread