Excel Makro Tabellenblattforlage duplizieren

Computer: Software & Programmierung Visual Basic
#1

Hi Leute, ich habe ein excel Makro Problem.
Ich habe hier ein Makro, welches mein Vorlagensheet 30mal kopiert.
Soweit so gut.
Allerdings muss zusätzlich zu der Kopie nun noch eine Bezeichnung in eine Zelle der neuen Sheets angelegt werden.
Die zu vergebenden Bezeichnungen befinden sich auch in dem Vorlagensheet. Die 30 Begriffe sind untereinander angeordnet und sollen nun der Reihe nach von oben nach unten, an die neuen Seiten, übergeben werden.
Hier ist das Makro:

Private Sub CommandButton1_Click()
Dim Zelle, Bereich As Range
Dim I As Integer
Dim nWS As Worksheet
Dim Bool As Boolean
Dim Bla As Boolean

Set Bereich = Range(„A2:A“ & Range(„A73“).End(xlUp).Row)

For Each Zelle In Bereich

For I = 1 To Worksheets.Count
If Worksheets(I).Name = Zelle.Value Then
Bool = True
Exit For
Else
Bool = False
End If
Next I

If Bool = False Then
Set nWS = Worksheets.Add(After:=Worksheets(Worksheets.Count))
nWS.Name = Zelle.Value
Else
Set nWS = Worksheets(Zelle.Text)
End If

With Worksheets(„Vorlage_Fragenkatalog“) 'Tabellennamen anpassen
'.Select
'.Rows(„1:75“).Copy Worksheets(nWS.Name).Range(„A:I“) 'Fragenkatalog kopieren
If Worksheets(nWS.Name).Range(„B1“) = „Thema“ Then
Bla = True
Else
.Range(„A:J“).Copy Worksheets(nWS.Name).Range(„A:J“) 'Fragenkatalog kopieren
'Worksheets(nWS.Name).Range(„A:I“).PasteSpecial Paste:=xlPasteFormats
End If
End With

Next Zelle
Application.CutCopyMode = False
End Sub

Private Sub CommandButton2_Click()
Dim I As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For I = ActiveWorkbook.Worksheets.Count To 1 Step -1
If Worksheets(I).Name Like „R?.*“ Then _
Worksheets(I).Delete
Next I
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Noch etwas zu dem Makro. Der erste Button erzeugt die 30 Seiten und der zweite löscht sie dann auch wieder.
Vielleicht wäre beim Löschen auch noch interessant, dass wenn eine der Kopien ausgefüllt wurde sie dann nicht wieder gelöscht wird. Das wäre allerdings nicht ganz so wichtig wie die übergabe der Bezeichnungen.

Ich bin für jede Hilfe mehr als dankbar.

#2

Hallo,

zeitbedingt kann ich nicht weiterhelfen.
Bitte um Verstädnis.

Carsten.HB

#3

Hallo,

also im Prinzip wäre es eine Anweisung for i=0 to 29 do …
so würde ich die Namen zuerst mal aus dem sheet einlesen. Dabei würde ich mal eine Msgbox anzeigen lassen, was eingelesen wurde. Um zu testen was passiert, wenn leere Felder eingelesen werden, sollte das hilfreich sein.
So ganz verstehe ich aber noch nicht wo das Problem liegt,

Gruss

#4

Hallo,

leider habe ich mich mit derartigen Zusammenhängen auch noch nicht befasst. Übrigens, warum schreibst du „…forlage“ mit f und nicht mit v. Geht es dabei um irgendetwas anderes?

MfG

willba

#5

Kann ich leider nicht helfen

#6

Hi

Allerdings muss zusätzlich zu der Kopie nun noch eine
Bezeichnung in eine Zelle der neuen Sheets angelegt werden.
Die zu vergebenden Bezeichnungen befinden sich auch in dem
Vorlagensheet. Die 30 Begriffe sind untereinander angeordnet
und sollen nun der Reihe nach von oben nach unten, an die
neuen Seiten, übergeben werden.

Einfach die Bezeichnung mitn Makro recorder aufzeichnen.

bei

 .Range("A:J").Copy Worksheets(nWS.Name).Range("A:J") 'Fragenkatalog kopieren
 'Worksheets(nWS.Name).Range("A:I").PasteSpecial Paste:=xlPasteFormats

einfügen das wars.

gruß Fred

#7

Hi
Zur Inhaltsangabe:
Grundlegend hast Du ja schon viele For-Schleifen
Bei dem Auslesen von einem Zelleninhalt kann man entweder (der Befehl mit Dim strTXT as String) den Befehl so:

strTxt = tabelle1.range("A5).value

oder so:

strTxt = tabelle1.cells(5,1)

schreiben, um den Inhalt der Variablen strTxt zuzuordnen. Beide Zuweisungen lesen den Inhalt der Zelle A5 und lesen den Wert aus und übergeben diesen in die Stringvariable strTXT.
Umgekehrt kannst Du einer Zelle einen Wert zuweisen:
tabelle1.cells(5,1) = strTxt
So, damit löst Du mal viele der beschriebenen Probleme, grundlegend.

Ersetze nun die Zahlen in tabelle1.cells(5,1) durch eine Variable vom Typ Long. Also:
Dim l as Long
l=1 'Wichtig, denn die Zelle „A0“ existiert nicht!
For l=1 to 5
strTxt = tabelle1.cells(5,l)
'Läuft die esten 5 Spalten A,B,C,D,E ab und dort die 5. Zeile.
'cells(5= Row = Zeile, l= Columne = Spalte)
next l

Wieso den Datentyp Long und nicht Integer?
Weil Integer bei rund 16300 endet.

Dein Löschproblemn könnte vereinfacht so aussehen:
If Tabelle2.cells(l,3)= „“ Then Exit Sub
oder:
If Tabelle2.cells(l,3)= „“ Then GoTo
oder:
If Tabelle2.cells(l,3)= „“ Then Exit For
oder:
If Tabelle2.cells(l,3)= „“ Then Exit Do

'3 Entspricht ibn diesem Fall der Spalte C
'1=A; 2=B; 3=C … usw.

Grüsse Sebastian

… mehr auf http://www.wer-weiss-was.de/app/query/display_query?..

#8

Ich weiß jetzt nicht, wo bei dir die Frage sein soll?
klar ist natürlich, das „Range(„A73“).End(xlUp).Row“ immer 1 liefert und somit nur die Blätter mit dem Namen aus Zelle A1 und aus Zelle A2 erzeugt werden…

#9

Hallo,

sorry keine Ahnung.

Grüße

#10

Bezeichnung in eine Zelle der neuen Sheets angelegt werden.
Die zu vergebenden Bezeichnungen befinden sich auch in dem
Vorlagensheet. Die 30 Begriffe sind untereinander angeordnet
und sollen nun der Reihe nach von oben nach unten, an die
neuen Seiten, übergeben werden.

Hallo,

hier kann ich dir nicht weiter helfen, Sooft beschäftige ich mich nicht mit Makros.

MfG
Johannes E.

#11

Hallo Timmbo,

dass sollte etwa wie folgt funktionieren. Die Zelladressen muss du natürlich anpassen. Evtl. muss du die neuen Zeilen in den Else-Teil deiner If-Prüfung verschieben.

Gruß
Franz

Private Sub CommandButton1\_Click()
Dim Zelle, Bereich As Range
Dim I As Integer, iOffset As Integer 'angepasst fcs
Dim nWS As Worksheet
Dim Bool As Boolean
Dim Bla As Boolean

Set Bereich = Range("A2:A" & Range("A73").End(xlUp).Row)

For Each Zelle In Bereich

For I = 1 To Worksheets.Count
If Worksheets(I).Name = Zelle.Value Then
Bool = True
Exit For
Else
Bool = False
End If
Next I

If Bool = False Then
Set nWS = Worksheets.Add(After:=Worksheets(Worksheets.Count))
nWS.Name = Zelle.Value
Else
Set nWS = Worksheets(Zelle.Text)
End If

With Worksheets("Vorlage\_Fragenkatalog") 'Tabellennamen anpassen
'.Select
'.Rows("1:75").Copy Worksheets(nWS.Name).Range("A:I") 'Fragenkatalog kopieren
If Worksheets(nWS.Name).Range("B1") = "Thema" Then
Bla = True
Else
.Range("A:J").Copy Worksheets(nWS.Name).Range("A:J") 'Fragenkatalog kopieren
'Worksheets(nWS.Name).Range("A:I").PasteSpecial Paste:=xlPasteFormats
End If
 'E2 = Zelle in die der zusätzliche Wert im neuen Blatt eingetragen werden soll
 'X2 = Zelle in Blatt "Vorlage\_Fragenkatalog" mit 1. einzutragenden Wert
 nWS.Range("E2") = .Range("X2").Offset(iOffset, 0).Value 'neu fcs
 iOffset = iOffset + 1 'neu fcs
End With

Next Zelle
Application.CutCopyMode = False
End Sub