Werte in mehreren Arbeitblättern kopieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

Hallo Ernst,
Makro 1:
Es gibt Unstimmigkeiten in deinen Ausgangsdaten.
Nr. 33 und 55: hier sind in den beiden Tabellen die Namen zu den Nummern vertauscht.
Nr. 114 und 168: Diese kommen in Tabelle2 doppelt vor.
Tabelle2

	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

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4.8
Tab1999

	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

Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4.8
Makro 2:
Hier stimmen die Namen in Zelle C1 der Blätter "Feicks", "StubbeV" und "StubbeH" nicht mit einem der Namen in Zeile 1 von Blatt "Tab 1999" überein. Bei allen 3 Blättern ist in C1 der Name "Radem." eingetragen.
Die Namen in C1 müssen genau mit einem Namen in Zeile 1 von Blatt "Tab 1999" übereinstimmen. Namen dürfen auch nicht doppelt vorkommen.
Nach Bereinigung der Unstimmigkeiten sollten die Makros korrekt arbeiten.
LG
Franz

Beliebteste Forumthreads (12 Monate)

Werte in mehreren Arbeitblättern kopieren

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Werte in mehreren Arbeitblättern kopieren

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

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread