Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1304to1308
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Zeilen auserten, kopieren und automatisch generier

Zeilen auserten, kopieren und automatisch generier
21.03.2013 22:33:49
mike
Hallo,
sehr schwierig mein Vorhaben in Worte zu fassen also besser mal das Beispiel ansehen
https://www.herber.de/bbs/user/84500.xls
Jetzt soll folgendes passieren:
Das Blatt Ergebnis soll quasi immer automatisch und variabel von "selbst" sein Inhalt generieren.
Es könnte also z.B ein vorlagensheet geben aus dem die Grundinformationen kopiert werden.
Der Positionsname soll aus "Allgemein" geholt werden.
Die Zeiel 5 ist immer gleich
Zeile 6 soll eingefügt werden, wenn im Sheet "Allgemein" in F6 was steht.
Zeile 7 wenn in Allgemein spalte F7 was steht...usw
Zeile 8 soll wieder fix sein. Wenn aber jetzt ein Tabellenblatt März eingefügt wird soll dies zwischen Zeile 7 und 8 rücken.
Wenn die Tabell für die erste Position aus "Allgemein" generiert ist soll automatisch das selbe für die nächste Position aus "Allgemein" erstellt werden. Also hier: 345
usw...

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Zeilen auserten, kopieren und automatisch generier
23.03.2013 19:12:20
fcs
Hallo Mike,
die folgenden Makros fügst du im VBA-Editor unter dem Tabellenblatt "Ergebnis" ein.
Immer wenn das Blatt Ergebnis selektiert wird, dann wird per Makro die Daten in das Blatt Ergebnis neu übertragen. Voraussetzung ist natürlich, dass die Makros beim Öffnen der Datei aktiviert werden.
Gruß
Franz
'Code im VBA-Editor unter Tabelle "Ergebnis"
Private Sub Worksheet_Activate()
Call UpdateErgebnis
End Sub
Sub UpdateErgebnis()
Dim wksAllg As Worksheet, wksTab As Worksheet, wksErgebnis As Worksheet
Dim ZeilePos As Long, ZeileTab As Long, ZeileErg As Long, AnzTab As Long
Dim ZellePos As Range
Dim varPos As Variant
On Error GoTo Fehler
Set wksAllg = Worksheets("Allgemein")
Set wksErgebnis = Worksheets("Ergebnis")
Application.ScreenUpdating = False
With wksErgebnis
'vorhandene Inhalte im Ergebnisblatt ab Zeile 4 löschen
ZeileErg = .Cells(.Rows.Count, 2).End(xlUp).Row
If ZeileErg >= 4 Then
.Range(.Rows(4), .Rows(ZeileErg)).Clear
End If
ZeileErg = 3 'Zeile unterhalb der Werte eingetragen werden sollen
End With
With wksAllg
'Positionen in Tabelle Allgemein abarbeiten
For ZeilePos = 6 To .Cells(.Rows.Count, 3).End(xlUp).Row
If .Cells(ZeilePos, 3)  "" Then
varPos = .Cells(ZeilePos, 3).Value
With wksErgebnis
ZeileErg = ZeileErg + 1
.Cells(ZeileErg, 2) = "Position"
.Cells(ZeileErg, 3) = varPos
ZeileErg = ZeileErg + 1
.Cells(ZeileErg, 4) = "Preis"
.Cells(ZeileErg, 5) = "Guthaben"
End With
AnzTab = 0 'Tabellenzähler zurücksetzen
'Daten in den Tabellenblättern auswerten
For ZeileTab = 6 To .Cells(.Rows.Count, 6).End(xlUp).Row
ZeileErg = ZeileErg + 1
'Tabellenname eintragen
wksErgebnis.Cells(ZeileErg, 2) = .Cells(ZeileTab, 6).Text
AnzTab = AnzTab + 1
Set wksTab = Worksheets(.Cells(ZeileTab, 6).Text)
With wksTab
'Positionsnummer in Spalte B im Tabellenblatt suchen
With .Range(.Cells(9, 2), .Cells(.Rows.Count, 2).End(xlUp))
Set ZellePos = .Find(what:=varPos, LookIn:=xlValues, lookat:=xlWhole)
End With
If ZellePos Is Nothing Then
'Positionsnummer in Tabellenblatt nicht gefunden
Else
'Daten zu Position in Ergebnis übertragen
wksErgebnis.Cells(ZeileErg, 4) = .Cells(ZellePos.Row, 4).Value 'Preis
wksErgebnis.Cells(ZeileErg, 5) = .Cells(ZellePos.Row, 5).Value 'Guthaben
End If
End With
NextWksTab:
Next ZeileTab
'Summenzeile eintragen inkl. Formeln
ZeileErg = ZeileErg + 1
With wksErgebnis
.Cells(ZeileErg, 2).Value = "Summe"
.Cells(ZeileErg, 4).FormulaR1C1 = "=SUM(R[-" & AnzTab & "]C:R[-1]C)"
.Cells(ZeileErg, 5).FormulaR1C1 = "=SUM(R[-" & AnzTab & "]C:R[-1]C)"
End With
ZeileErg = ZeileErg + 3 'Leerzeilen nach Summenzeile
End If
Next ZeilePos
End With
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case 9 'Index-Fehler - Tabelle mit Name nicht vorhanden
Resume NextWksTab
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
Application.ScreenUpdating = True
Set wksTab = Nothing: Set wksErgebnis = Nothing: Set wksAllg = Nothing
Set ZellePos = Nothing
End Sub

Anzeige
AW: Zeilen auserten, kopieren und automatisch generier
23.03.2013 20:47:04
mike
WOW!!!
Das ist wirklich genial!!!
Aber jetzt hab ich ein Problem und zwar war das nur eine Beispieldatei...ich hab versucht es auf die Original zu übertragen aber das ist für mich nicht so einfach..kannst du mir helfen?!
Ausserdem soll immer dort, wo eine blaue Schrift ist von Hand was eingetragen werden können und mit dieser Funktion "lösche alles ab der 4. Zeile" ist das dann leider immer weg
https://www.herber.de/bbs/user/84522.xls
Danke

AW: Zeilen auserten, kopieren und automatisch generier
24.03.2013 16:20:59
fcs
Hallo Mike,
bedingt durch die Formeln im Zusammenstellungs-Blatt ist das Ganze jetzt wesentlich komplizierter geworden. Insbesondere das Einfügen von Zeilen für weitere Tabellenblätter/Geschosse erfordert einiges an Maßnahmen, damit die Formel nach dem Einfügen korrekt bleiben.
Das Makro fügt alle bisher durch SVERWEIS berechneten Werte als feste Werte im Blatt ein.
https://www.herber.de/bbs/user/84526.xls
Gruß
Franz

Anzeige
AW: Zeilen auserten, kopieren und automatisch gene
24.03.2013 18:07:06
mike
Hallo Franz,
danke für deine Hilfe.
Wäre natürlich schon wenn das Ganze "idiotensicher" wäre und man nicht noch in der VBA was ändern müsste.
Ist auch noch ein kleiner Fehler drin, wenn man mehrere Geschosse einfügt dann wird bei der Lastsumme immer die 12. Zeile addiert und nicht die Zeile oberhalb.
Gruß

AW: Zeilen auserten, kopieren und automatisch gene
24.03.2013 18:22:07
mike
Hallo Franz,
meinst du du kannst mir auch noch dabei Helfen?
https://www.herber.de/forum/messages/1305386.html
Und zwar gehts dabei um die Tabellenbätter z.b. "4.UG", dass dort nicht so viele Nullen stehen soll immer wenn im Eingabeblatt eine Position hinzukommt oder wegfällt oder umbenannt wird eine Zeile oberhalb der letzten eingefügten Zeile eingefügt werden..

Anzeige
AW: Zeilen auserten, kopieren und automatisch gene
24.03.2013 18:56:45
fcs
Hallo Mike,
es hätte mich sehr gewundert, wenn bei der Komplexität der erforderlichen Kopiervorgänge alles auf Anhieb fehlerfrei funktioniert hätte.
Den folgenden Abschnitt im Makro muss du Ändern damit die Summenbildung korrekt funktioniert
          'Formeln in letzter Zeile durch kopieren wieder korrigieren
.Cells(ZeileErg - (AnzTabNeu - AnzTab) + 1, 2).Copy
.Range(.Cells(ZeileErg - (AnzTabNeu - AnzTab) + 2, 2), _
.Cells(ZeileErg - 1 + AnzTabNeu - AnzTab, 2)).PasteSpecial _
Paste:=xlPasteFormulas
.Range(.Cells(ZeileErg - (AnzTabNeu - AnzTab) + 1, 11), _
.Cells(ZeileErg - (AnzTabNeu - AnzTab) + 1, 30)).Copy
.Range(.Cells(ZeileErg - (AnzTabNeu - AnzTab) + 2, 11), _
.Cells(ZeileErg - 1 + AnzTabNeu - AnzTab, 30)).PasteSpecial _
Paste:=xlPasteFormulas

Die Anpassung im VBA-Code kann man umgehen, wenn man eine zusätzliche Prüfung einbaut.
Private Sub Worksheet_Activate()
If LCase(Me.Name)  LCase("Musterzusammenstellung") Then
Call UpdateErgebnis(wksErgebnis:=Me)
End If
End Sub

Hier geht es darum, dass nicht versehentlich das Muster per Makro überschrieben wird.
Gruß
Franz

Anzeige
AW: Zeilen auserten, kopieren und automatisch gene
26.03.2013 20:34:14
mike
Hallo Franz ,
dank dir werds erst mal so probieren und ausgiebig testen.
Gruß

299 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige