Macro für Zellinhalte bei unterschiedlichen Vorlagen

Es gibt 4 verschiedene Vorlagen.
Davon brauche ich aber nur bestimmte Zellbereiche für die weitere Berarbeitung in einer anderen Datei.
Es wird ein Macro benötigt,welches Werte in folgenden Bereichen (in Abhängigkeit der Merkmale) kopiert und in Blatt "Einfügen" beginnend bei B7 eingefügt.
Dies ohne Rahmen; Formatierungen etc. nur Daten.
Auch sollen die Inhalte von mehrblättrigen nacheinander eingefügt werden.
Jedoch ohne Blattköpfe und Fußzeilen, die ausgeklammert werden sollen.
Hier meine Mappe- Beginne in Hilfstabelle :-)
https://www.herber.de/bbs/user/134191.xlsm
An folgenden Merkmalen wir erkannt, ob es ein ; zwei, drei oder vier Blatt Dokument ist.
Blatt1 keine Daten in C5;D6 Text, Zahl
Blatt2 Daten C5; D5 und C24; D24 Text, Zahl
Blatt3 Daten C5; D5;C24;D24 und C43;D43 Text, Zahl
Blatt4 Daten C5; D5;C24;D24;C43;D43und C62;D62 Text, Zahl
Nach Auswertung der Merkmale
1 Blatt "Vorhanden" (keine Daten in C5;D6 )dann
Bereich B7-D17 kopieren und in Blatt "Einfügen" beginnend bei B7 einfügen
*fertig
2 Blatt "Vorhanden" (Daten in C5; D5 und C24; D24)
Bereich B7-D20 kopieren und in Blatt "Einfügen" beginnend bei B7 einfügen
Bereich B26-D36 kopieren und in Blatt "Einfügen" weiter bei B21 einfügen
*fertig
3 Blatt"Vorhanden" (Daten C5; D5;C24;D24 und C43;D43)
Bereich B7-D20 kopieren und in Blatt "Einfügen" beginnend bei B7 einfügen
Bereich B26-D39 kopieren und in Blatt "Einfügen" nachfolgend bei B21 einfügen
Bereich B45-D55 kopieren und in Blatt "Einfügen" weiter bei B35 einfügen
*fertig
4 Blatt"Vorhanden" (Daten C5; D5;C24;D24;C43;D43und C62;D62)
Bereich B7-D20 kopieren und in Blatt "Einfügen" beginnend bei B7 einfügen
Bereich B26-D39 kopieren und in Blatt "Einfügen" nachfolgend bei B21 einfügen
Bereich B45-D58 kopieren und in Blatt "Einfügen" weiter bei B35 einfügen
Bereich B64-D74 kopieren und in Blatt "Einfügen" bei B51 einfügen
*fertig
Wer kann mir beim Code helfen?
Gruß Andreas

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Public Sub Daten_übertragen() Dim raBereich As Range With Worksheets("Hilfstabelle") Select Case .Range("C5") & .Range("D5") Case "" If .Range("C7") "" Then Set raBereich = .Range("B7:D17") End If Case "Blatt1v2" Set raBereich = .Range("B7:D20,B26:D36") Case "Blatt1v3" Set raBereich = .Range("B7:D20,B26:D39,B45:D55") Case "Blatt1v4" Set raBereich = .Range("B7:D20,B26:D39,B45:D58,B64:D74") Case Else End Select If Not raBereich Is Nothing Then Application.ScreenUpdating = False If .Range("D5") = "" Then If MsgBox("Soll 1 Blatt übertragen werden?", vbOKCancel, "Blätter übertragen") _ = vbOK Then Worksheets("Einfügen").Columns("B:D").ClearContents raBereich.Copy Worksheets("Einfügen").Range("B7").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False End If Else If MsgBox("Sollen " & Right(.Range("D5"), 1) & " Blätter übertragen werden?", _ vbOKCancel, "Blätter übertragen") = vbOK Then Worksheets("Einfügen").Columns("B:D").ClearContents raBereich.Copy Worksheets("Einfügen").Range("B7").PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False End If End If Else MsgBox "Keine Blätter zum Übertragen vorhanden." End If End With Set raBereich = Nothing End Sub

Hallo Werner,
hier der Code- nun doch nicht so läuft.

Public Sub Daten_übertragen()
Dim raBereich As Range
With Worksheets("Bestand")
Select Case .Range("O7") & .Range("P7")
Case ""
If .Range("B4")  "" Then
Set raBereich = .Range("A26:Q46")
End If
Case "Blatt2"
Set raBereich = .Range("A26:Q55,A69:Q97")
Case "Blatt3"
Set raBereich = .Range("A26:Q55,A69:Q108,A121:Q149")
Case "Blatt4"
Set raBereich = .Range("A26:Q55,A69:Q108,A121:Q149,A173:Q201")
Case Else
End Select
If Not raBereich Is Nothing Then
Application.ScreenUpdating = False
If .Range("P7") = "" Then
If MsgBox("Soll 1 Blatt übertragen werden?", vbOKCancel, "Blätter übertragen") _
= vbOK Then
Worksheets("Bearbeiten").Range("A4:Q250").ClearContents
'Worksheets("Bearbeiten").Columns("A4:Q250").ClearContents
raBereich.Copy
Worksheets("Bearbeiten").Range("A4").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
Else
If MsgBox("Sollen " & Right(.Range("P7"), 1) & " Blätter übertragen werden?", _
vbOKCancel, "Blätter übertragen") = vbOK Then
Worksheets("Bearbeiten").Range("A4:Q250").ClearContents
raBereich.Copy
Worksheets("Bearbeiten").Range("A4").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
End If
Else
MsgBox "Keine Blätter zum Übertragen vorhanden."
End If
End With
Set raBereich = Nothing
End Sub

Mit der kleinen Beispieldatei geteset, da lief das Makro. Jedoch nach der Überarbeitung ging nix mehr- da ist noch was im argen.
Das Grundprinzip aber klappt- denke ich.
Worksheets("Bestand") kann bis zu 4 Blätter enthalten. Von da werden bestimmte Zellen ins Blatt Worksheets("Bearbeiten").Range("A4") kopiert.
Wichtig: geleert werden darf im Worksheets("Bearbeiten").Range("A4:Q250").ClearContents,
Formatierungen und Blattköpfe müssen erhalten werden.
Die Blätter werden so auseinander gehalten:
1 Blatt Dokument , dann ist Zelle O7 und P7 "leer".
2 Blatt Dokument, dann in Zelle O7 "Blatt" und Zelle P7 eine "1" + Zelle O62 "Blatt" und Zelle P62 eine "2"
3 Blatt Dokument, dann in Zelle O7 "Blatt" und Zelle P7 eine "1" + Zelle O62 "Blatt" Zelle P62 eine "2" + Zelle O115 "Blatt" und Zelle P115 eine "3"
4 Blatt Dokument, dann in Zelle O7 "Blatt" und Zelle P7 eine "1" + Zelle O62 "Blatt" Zelle P62 eine "2" + Zelle O115 "Blatt" und Zelle P115 eine "3" und Zelle O167 "Blatt" und Zelle P167 eine "4".
Je nach dem, welches Blatt in Worksheets("Bestand") vorliegt, soll bei
1 Blatt Dokument der raBereich = .Range("A26:Q46") von ("Bestand") kopieren und nach Worksheets("Bearbeiten").Range("A4").PasteSpecial Paste:=xlPasteValues einfügen
#vorher bitte in Worksheets("Bearbeiten").Range("A4:Q250").ClearContents, weil ich die Formatierungen benötige. Auch den Bereich oberhalb nicht löschen.
2 Blatt Dokument raBereich = .Range("A26:Q55,A69:Q97")
3 Blatt Dokument raBereich = .Range("A26:Q55,A69:Q108,A121:Q149")
4 Blatt Dokument raBereich = .Range("A26:Q55,A69:Q108,A121:Q149,A173:Q201")
Die Msg Boxen waren auch gut. MsgBox("Soll 1 Blatt übertragen werden?"
MsgBox("Sollen " & Right(.Range("P7"), 1) & " Blätter übertragen werden?"
Ist es noch möglich, evtl. nach Ablauf des Makros zu Worksheets("Bearbeiten")in die Zelle A7 zu springen,
um evtl.die Daten einer Sichtprüfung mit MSG Box z.B. Daten Überprüfen, bevor Blatt"Vorhanden"gelöscht wird.
Wird eine MSG Box angezeigt kann man aber nicht mit der Maus mal noch nach unten scrollen- würde dies auch funktionieren?
Wenn dann alles "ok" ist würde soll das Worksheets("Vorhanden") gelöscht werden.
Vieleicht kannst du noch mal schauen?
Grüße Andreas

Beliebteste Forumthreads (12 Monate)

Macro für Zellinhalte bei unterschiedlichen Vorlagen

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread