kopieren und einfügen nicht angrenzender Zellen

Public Sub Archivieren() Dim TOP1 As Range, TOP2 As Range, TOP3 As Range, TOP4 As Range, TOP5 As Range, TOP6 As Range, Dim TOP7 As Range, TOP8 As Range TOP9 As Range, TOP10 As Range, TOP11 As Range, TOP12 As Range Dim TOP13 As Range, TOP14 As Range, TOP15 As Range Set TOP1 = Sheets("Protokoll").Range("C1,C8,E11,U13,M13,E13,E14") Set TOP2 = Sheets("Protokoll").Range("C1,C16,E19,U21,M21,E21,E22") Set TOP3 = Sheets("Protokoll").Range("C1,C24,E27,U29,M29,E29,E30") Set TOP4 = Sheets("Protokoll").Range("C1,C32,E35,U37,M37,E37,E38") Set TOP5 = Sheets("Protokoll").Range("C1,C40,E43,U45,M45,E45,E46") Set TOP6 = Sheets("Protokoll").Range("C1,C48,E51,U53,M53,E53,E54") Set TOP7 = Sheets("Protokoll").Range("C1,C56,E59,U61,M61,E61,E62") Set TOP8 = Sheets("Protokoll").Range("C1,C64,E67,U69,M69,E69,E70") Set TOP9 = Sheets("Protokoll").Range("C1,C72,E75,U77,M77,E77,E78") Set TOP10 = Sheets("Protokoll").Range("C1,C80,E83,U85,M85,E85,E86") Set TOP11 = Sheets("Protokoll").Range("C1,C88,E91,U93,M93,E93,E94") Set TOP12 = Sheets("Protokoll").Range("C1,C96,E99,U101,M101,E101,E102") Set TOP13 = Sheets("Protokoll").Range("C1,C104,E107,U109,M109,E109,E110") Set TOP14 = Sheets("Protokoll").Range("C1,C112,E115,U117,M117,E17,E118") Set TOP15 = Sheets("Protokoll").Range("C1,C120,E123,U125,M125,E125,E126") TOP1.Copy Sheets("Archiv").Range("A65536").End(xlUp).PasteSpecial Paste:=xlValue Application.CutCopyMode = False End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub sbKopierenEinfuegen(ByVal zellen As String) Dim lstrSplit() As String, liIdx As Integer Dim lshArchiv As Worksheet, lshProtokoll As Worksheet Dim lloRowNext As Long, lloCol As Long Set lshProtokoll = Sheets("Protokoll") Set lshArchiv = Sheets("Archiv") lstrSplit = Split(zellen, ",") lloRowNext = lshArchiv.Cells(Rows.Count, 1).End(xlUp).Row + 1 lloCol = 1 For liIdx = 0 To UBound(lstrSplit) lshArchiv.Cells(lloRowNext, lloCol).Value = lshProtokoll.Range(lstrSplit(liIdx)). _ Value lloCol = lloCol + 1 Next Set lshProtokoll = Nothing Set lshArchiv = Nothing End Sub

Public Sub Archivieren() Dim arrP, arrA Dim zA As Long, zP As Long Dim Ende As Long arrP = Sheets("Protokoll").UsedRange.Value ReDim arrA(1 To WorksheetFunction.CountA(Sheets("Protokoll").Range("U8:U999")), 1 To 7) For zP = 8 To UBound(arrP, 1) Step 8 If arrP(zP + 5, 21) "" Then 'nur Protokollzeilen mit Status übernehmen zA = zA + 1 arrA(zA, 1) = arrP(2, 3) 'Datum arrA(zA, 2) = arrP(zP + 0, 3) 'Top arrA(zA, 3) = arrP(zP + 3, 5) 'Aufgabe arrA(zA, 4) = arrP(zP + 5, 21) 'Status arrA(zA, 5) = arrP(zP + 5, 13) 'Termin arrA(zA, 6) = arrP(zP + 5, 5) 'Verantwortlichr arrA(zA, 7) = arrP(zP + 6, 5) 'Ergebnis If zA = UBound(arrA, 1) Then Exit For End If Next With Sheets("Archiv").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) .Resize(UBound(arrA, 1), UBound(arrA, 2)).Value = arrA End With End Sub

…Micha; ;-]
dass ein diskontinuierlicher Bereich nicht per Kopie irgendwo eingefügt wdn kann, sollte ja nun klar sein. Andererseits kann man aber tatsächlich mit solchen Bereichen sinnvoll arbeiten, obwohl hier ja, bei deiner regelmäßigen TabStruktur, auch eine ganz simple WertÜbernahme per direktem FmlVerweis möglich wäre. Das ist eigentlich das Naheliegendste und kann auch per VBA so gemacht wdn, sogar zyklisch (ich nehme mal an, dass auch Thorsten das so gemacht hatte). Das ist allerdings trivial und uninteressant, weshalb ich hier mal auf deinen ursprünglichen Ansatz zurückkommen will.
Man kann mit einem solchen Ansatz eine einzige Fml für alle Zellen des Blattes Archiv konstruieren, wobei es 3 prinzipielle Möglichkeiten auf der Basis von INDEX bzw - etwas komplizierter - INDIREKT gibt:
1. Eine im Prinzip gleiche (Normal-)Fml für jede Zelle, die sich von Zelle zu Zelle beim Kopieren anpasst (im Folgenden nicht dargestellt);
2. Eine plurale MatrixFml für eine ganze Zeile (im Folgenden auf Basis von INDIREKT in Kombination mit INDEX);
3. Eine plurale MatrixFml für die gesamte Tabelle (im Folgenden nur auf Basis von INDEX).
Die alternativen Fmln zu 2 und 3:
A2:G2[;A3:G5]: {=INDEX((Protokoll!C$2;INDIREKT("Protokoll!C"&ZEILE(A1)*8);INDIREKT("Protokoll!E"&ZEILE(A1)*8+3);INDIREKT("Protokoll!U"&ZEILE(A1)*8+5);INDIREKT("Protokoll!M"&ZEILE(A1)*8+5);INDIREKT("Protokoll!E"&ZEILE(A1)*8+5);INDIREKT("Protokoll!E"&ZEILE(A1)*8+6));;;SPALTE(A:G))}
A2:G5: {=WENN(SPALTE()=1;Protokoll!C2;INDEX((Protokoll!C2;Protokoll!C8:C120;Protokoll!E11:E123;Protokoll!U13:U125;Protokoll!M13:M125;Protokoll!E13:E125;Protokoll!E14:E126);(ZEILE(1:4)-1)*8+1;;SPALTE(A:G)))}
Die Bereichsangabe der oberen Fml für INDEX ist so möglich, weil INDIREKT stets ZellBezüge liefert, während INDEX sowohl für Bereiche als auch Datenfelder (im Ergebnis von Ausdrücken) verwendet wdn kann (in beiden Fällen auch mit 4.Argument, wenn auch für Datenfelder mit etwas anderer Funktion). Diese können per Klammerung zu einem diskontinuierlichen Bereich für INDEX vereinigt wdn.
Auf der Basis der unteren Fml kann auch ein VBA-Pgm geschrieben wdn, dass diese Fml in den GesamtTabellenBereich einträgt und ggf durch ihre Ergebnisse ersetzt. Sofern der Bereich nicht übermäßig groß ist, sollte das eine sehr schnelle Lösung sein. Da allerdings der FmlText in voller Form hier länger als 255 Zeichen wird, wird im folgenden Pgm ein Name definiert, dem dieser FmlText übergeben wird. Dieser Name wird dann als MatrixFml (.FormulaArray) verwendet:

Option Explicit
Sub ArchivNurWerte(): Call Archiv(True): End Sub
Sub Archiv(Optional ByVal nurWerte)
Const QBloZln As Long = 8, ZZlDiff As Long = 2, ZykLim As Long = 4, _
adQBer$ = "!C$2,!C$8:C$120,!E$11:E$123,!U$13:U$125," & _
"!M$13:M$125,!E$13:E$125,!E$14:E$126", adZBer$ = "A$2:G$16", _
naArFml$ = "_ArrFml", naQBl$ = "! Protokoll!", naZBl$ = "Archiv", _
txArrFml$ = "=if(column()=1,#0,index((#1),(row(!#2)-#3)*#4+1,,column(!#2)))"
Dim ix As Long, adVoQBer$, adVoQ1TBer$, axVoWx$(), arrFml$, avVoQBer As Variant, _
xZ As Range, zBer As Range
On Error Resume Next
If IsMissing(nurWerte) Then nurWerte = False
axVoWx = Split(naQBl): arrFml = Replace(txArrFml, axVoWx(0), axVoWx(1))
adVoQBer = Replace(adQBer, axVoWx(0), axVoWx(1))
adVoQ1TBer = Split(adVoQBer, ",")(0)
avVoQBer = Array(adVoQ1TBer, adVoQBer, adZBer, CStr(ZZlDiff), CStr(QBloZln))
For ix = 0 To ZykLim
arrFml = Replace(arrFml, "#" & CStr(ix), avVoQBer(ix))
Next ix
If IsError(ActiveWorkbook.Names(naArFml)) Then
ActiveWorkbook.Names.Add naArFml, arrFml
Else: ActiveWorkbook.Names(naArFml).RefersTo = arrFml
End If
Set zBer = Worksheets(naZBl).Range(adZBer): zBer.FormulaArray = "=" & naArFml
If CBool(nurWerte) Then
zBer.Formula = zBer.Value: ActiveWorkbook.Names(naArFml).Delete
For Each xZ In zBer
If xZ = 0 Then xZ = Empty
Next xZ
End If
Set zBer = Nothing
End Sub

Das 1zeilige Pgm stellt hier einen alternativen Zugang zum nachfolgenden HauptPgm dar, der benutzt wdn kann, wenn die Fmln durch ihre Ergebnisse ersetzt wdn sollen. Dann wird auch der definierte Name nicht mehr benötigt und wird deshalb wieder, ebenso wie 0-Werte, gelöscht.
Außerdem zeigt dieses Pgm, dass man möglichst auch mit PgmKonstanten (am PgmAnfang) arbeiten soll, was ggf erforderliche PgmAnpassungen erleichtert. Leider wird so etwas (hier) von den Wenigsten beachtet…
Feedback nicht unerwünscht! Gruß, Luc :-?
„Die Intelligenzmenge ist auf diesem Planeten eine Konstante, die Bevölkerung nimmt aber zu!“ Auch deshalb informieren mit …

With Sheets("Archiv").Cells(Rows.count, 1).End(xlup).Offset(1, 0) with .Resize(Worksheetfunction.CountA(Sheets("Protokoll").Range("U9:U1000")), 7) .Formula = "=Index(Protokoll!$A:$Z;Row(A1)*8+A$1;A$2) .Columns(1).Formula = "=Protokoll!$C$2" .Formula = .Value end with end with

Mein Betreff war anhand eines wohl unstrittigen Faktums gewählt und sagt nichts darüber aus, was für eine Art von Fml-Lösung gemeint ist. Das ergibt sich erst aus dem Text, der erklären soll, wie man eine Vorgabe als diskontinuierlicher Bereich in eine Fml-Lösung umsetzen kann. Das allein war mein Ziel, denn dabei kann man zu dieser, vom Anfangsbeitrag aufgeworfenen Frage Wesentliches lernen. Alles Andere, auch wenn es hier ggf angebracht wäre (ich hatte das erwähnt), fällt unter Vermeidung dieses Problems und trägt folglich nichts zum Erkenntnisgewinn bzgl der speziellen Thematik bei. Wer immer nur zu vermeiden trachtet, wird kaum zu neuen Erkenntnissen gelangen… :-]
Den Zusammenhang zwischen den beiden Konstanten und vor allem, warum ich sie verwende, scheinst du nicht recht verstanden zu haben. Tauscht man sie aus, kann man das auch auf eine andere Fml anwenden. Wenn so etwas hochflexibel sein muss, würde ich ja auch eher eine UDF schreiben, aber darum ging's ja hier ebenfalls nicht.
Insofern scheint dein recht verspätet nachgeschobener 1.Beitrag eher einem „narzisstischen“ Geltungsbedürfnis* als thematischem Diskussionswillen entsprungen zu sein… :->
* Reiner Altruismus ist wohl bei den Allermeisten nicht das treibende Motiv, vor allem wohl dann, wenn sie sehr hohe wöchentliche oder gar tägliche Beitragsfrequenzen vorzuweisen haben… :-]
Luc :-?

Beliebteste Forumthreads (12 Monate)

kopieren und einfügen nicht angrenzender Zellen

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

349 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

kopieren und einfügen nicht angrenzender Zellen

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

349 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread