Werte von einem Sheet in ein anderes kopieren

Moin Leute,
erstmal danke an alle, die bereits Fragen gestellt haben, und selbstverstaendlich auch an die, die so hilfsbereit waren, die Fragen zu beantworten. Dadurch konnte ich bereits einige meiner Probleme selber loesen.
Nun haenge ich fest, und hoffe, ihr koennt mir dabei helfen mein Problem zu loesen.
Ich moechte gerne aus einem Sheet Daten in ein anderes kopieren mit Hilfe der Index Formel. Ueber Excelformeln habe ich das Problem loesen koennen, aber ich habe keinen Anhaltspunkt, wie ich das ueber VBA loesen kann (ist aber leider notwendig).
Kurze Erklaerung:
Aus dem Sheet "Daten" soll "Summe an h in der Kalenderwoche" in das Sheet "Tabelle" uebertragen werden. Dabei soll die Zahl in die passende Kalenderwoche eingetragen werden, der Name und die Area sollten natuerlich auch uebereinstimmen. (Sorry fuer die schwache Erklaerung, aber wenn ihr das File seht, werdet ihr hoffentlich schlauer draus.)
Der Wert aus F soll in das Sheet "Tabelle" kopiert werden, und zwar genau in die Zelle, die mit der Kalenderwoche, dem Namen und der Area aus "Tabelle" uebereinstimmt.
Die Zahl sollte als fester Wert rueberkopiert werden, da das Sheet "Daten" nach einem Durchlauf gecleared wird.
Es handelt sich hierbei nur um ein Teil meines ganzen Vorhabens, daher mag es sein, dass es unvollstaendig erscheint.
Downloadlink: https://www.herber.de/bbs/user/102078.xlsx

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub KopiereDatenNachTabelle() Dim objDaten As Object, arrDaten, arrTab, i As Long, j As Long Dim sKey As String Const sDelim As String = "|" Set objDaten = CreateObject("scripting.dictionary") arrDaten = Sheets("Daten").Cells(1, 1).CurrentRegion For i = 2 To UBound(arrDaten) sKey = Join(Array(arrDaten(i, 1), arrDaten(i, 4), arrDaten(i, 5)), sDelim) objDaten(sKey) = objDaten(sKey) + arrDaten(i, 6) Next With Sheets("Tabelle") arrTab = .Range(.Cells(3, 1), .Cells(.Rows.Count, 1).End(xlUp)) _ .Resize(, .Cells(3, .Columns.Count).End(xlToLeft).Column) End With For i = 2 To UBound(arrTab) For j = 5 To UBound(arrTab, 2) sKey = Join(Array(arrTab(i, 4), arrTab(i, 1), arrTab(1, j)), sDelim) If objDaten.exists(sKey) Then arrTab(i, j) = objDaten(sKey) objDaten.Remove (sKey) End If Next j Next i If objDaten.Count Then MsgBox "Fehlende Namen/ Area-Kombinationen in Tabelle!" & vbLf _ & "Ergänzen und neu starten." & vbLf & Join(objDaten.keys, vbLf), _ vbOKOnly, "FEHLER!!!" Else Sheets("Tabelle").Cells(3, 1).Resize(UBound(arrTab), UBound(arrTab, 2)) = arrTab End If End Sub

Hey Rudi,
ich bin leider leicht ueberfordert mit dem Anpassen des Codes. Ich haette von vornherein daran denken koennen, die Beispiel-Datei so anzulegen wie die tatsaechliche Datei.
Der Code laeuft, wie bereits geschrieben, wunderbar. Auch wenn neue Daten hinzukommen (das war naemlich meine erste Sorge, aber daran hast du anscheinend direkt gedacht, danke auch dafuer).
Ich habe noch mal ein File hochgeladen, mit anderen Werten (Reihen und Spalten), waerst du eventuell so freundlich und koenntest den Code anpassen?

Sub KopiereDatenNachTabelle()
Dim objDaten As Object, arrDaten, arrTab, i As Long, j As Long
Dim sKey As String
Const sDelim As String = "|"
Set objDaten = CreateObject("scripting.dictionary")
arrDaten = Sheets("Daten").Cells(1, 1).CurrentRegion
For i = 2 To UBound(arrDaten)
sKey = Join(Array(arrDaten(i, 1), arrDaten(i, 5), arrDaten(i, 7)), sDelim)
objDaten(sKey) = objDaten(sKey) + arrDaten(i, 9)
Next

Den Part habe ich glaube ich richtig angepasst.
Ich blicke hier im unteren Part jedoch leider nicht durch.


With Sheets("Tabelle")
arrTab = .Range(.Cells(3, 1), .Cells(.Rows.Count, 1).End(xlUp)) _
.Resize(, .Cells(3, .Columns.Count).End(xlToLeft).Column)
End With
For i = 2 To UBound(arrTab)
For j = 5 To UBound(arrTab, 2)
sKey = Join(Array(arrTab(i, 4), arrTab(i, 1), arrTab(1, j)), sDelim)
If objDaten.exists(sKey) Then
arrTab(i, j) = objDaten(sKey)
objDaten.Remove (sKey)
End If
Next j
Next i
If objDaten.Count Then
MsgBox "Fehlende Namen/ Area-Kombinationen in Tabelle!" & vbLf _
& "Ergänzen und neu starten." & vbLf & Join(objDaten.keys, vbLf), _
vbOKOnly, "FEHLER!!!"
Else
Sheets("Tabelle").Cells(3, 1).Resize(UBound(arrTab), UBound(arrTab, 2)) = arrTab
End If
End Sub

Neue Datei: https://www.herber.de/bbs/user/102092.xlsx
Sorry noch mal fuer die Mehrarbeit (falls du sie dir ueberhaupt antust :D).

Sub KopiereDatenNachTabelle() Dim objDaten As Object, arrDaten, arrTab, i As Long, j As Long Dim objError As Object, oDaten Dim sKey As String Const sDelim As String = "|" Set objDaten = CreateObject("scripting.dictionary") Set objError = CreateObject("scripting.dictionary") arrDaten = Sheets("Daten").Cells(1, 1).CurrentRegion For i = 2 To UBound(arrDaten) sKey = Join(Array(arrDaten(i, 1), arrDaten(i, 5), arrDaten(i, 7)), sDelim) objDaten(sKey) = objDaten(sKey) + arrDaten(i, 9) Next With Sheets("Tabelle") arrTab = .Range(.Cells(4, 1), .Cells(.Rows.Count, 1).End(xlUp)) _ .Resize(, .Cells(4, .Columns.Count).End(xlToLeft).Column) End With For i = 5 To UBound(arrTab) For j = 5 To UBound(arrTab, 2) sKey = Join(Array(arrTab(i, 4), arrTab(i, 1), arrTab(1, j)), sDelim) If objDaten.exists(sKey) Then arrTab(i, j) = objDaten(sKey) objDaten.Remove (sKey) End If Next j Next i If objDaten.Count Then For Each oDaten In objDaten objError(Join(Array(Split(oDaten, sDelim)(0), Split(oDaten, sDelim)(1)), sDelim)) = 0 Next MsgBox "Fehlende Namen/ Area-Kombinationen in Tabelle!" & vbLf _ & "Ergänzen und neu starten." & vbLf & Join(objError.keys, vbLf), _ vbOKOnly, "FEHLER!!!" Else Sheets("Tabelle").Cells(4, 1).Resize(UBound(arrTab), UBound(arrTab, 2)) = arrTab End If End Sub

Beliebteste Forumthreads (12 Monate)

Werte von einem Sheet in ein anderes kopieren

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Werte von einem Sheet in ein anderes kopieren

5 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)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread