Vokalkarten

ich habe als Neuling für das Vokabelkarten Problem eine Makro Lösung
Die Werte für Spaltenbreite und Zeilenhöhe der Vokabelkarten sowie
die Breite und Höhe für die Schnittstellen der Druckerei können im
Global Const Feld manuell auf den gewünschten Wert gesetzt werden!
Wichtig ist, dass das ausfüllen automatisch erfolgt (keine Formel)
Das nachfolgende Progrtamm muss in 3 neue Module kopiert werden
Es würde mich freuen wenn es weiterhilft
Über eine Rückmeldung würde ich mich freuen
'Antwort auf: Vokabelkarten mit Excel Roy 04.06.2014 12:10:50 (Module 1 bis 3)
Option Explicit 'Modul1
Global Const instZeilen = 1750 'Anzahl der Zeilen zum installieren 10.000 / 6 = 1667
Global Const ZeilenBereich = "1:3500" 'Zeilenbereich (Anzahl Zeilen mit Schnittflaechen)
Global Const SpaltenBereich = "B:G" 'Spaltenbereich (kann auf "A:F" geaendert werden)
Global Const SpaltenBreite = 20 'Spaltenbreite der Vokabelkarten (Wert selbst eingeben)
Global Const ZeilenHöhe = 30 'Zeilenhöhe der Vokalkarte angeben (Wert selbst eingeben)
Global Const CutHöhe = 8 'Zeilenhöhe zum schneiden (Wert selbst eingeben)
Global Const CutBreite = 2 'Spaltenbreite zum schneiden (Wert selbst eingeben)
Global Const Zeile_1 = 1 '1. Zeile zum ausfüllen (auf Zeile 1 gesetzt)
Global Const Spalte_1 = 2 '1. Spalte zum ausfüllen (auf Spalte 2 gesetzt)
'Hinweis zur Spalte_1: '** wird der Spaltenbereich auf "A:F" geaendert muss Spalte_1 auf 1 gesetzt werden !! **
'Programmerklaerung: s. Modul 2 Die ZeilenHöhe / Spaltenbreite kann manuell geaendert werden (selbst einstellen)
'In die Excel Datei müssen im VBA Editor 3 neue Module angelegt werden: Module 1-3. Diesen Text bitte hinein kopieren

Sub Tabelle2_installieren()               ' (Modul 1)  Install Modul
Dim i, j
Sheets("Tabelle2").Select
'stellt Spaltenbreite und Zeilenhöhe ein
Rows(ZeilenBereich).RowHeight = ZeilenHöhe
Columns(SpaltenBereich).ColumnWidth = SpaltenBreite
Application.ScreenUpdating = False
'Schleife für Zeilen Cut-Höhe einstellen
j = Zeile_1   'j = 1. Zeile  (4 gewaehlt)
For i = 1 To instZeilen
Rows(j).RowHeight = CutHöhe
j = j + 2
Next i
'Spalten Cut-Breite einstellen
Columns(1).ColumnWidth = CutBreite
Columns(3).ColumnWidth = CutBreite
Columns(6).ColumnWidth = CutBreite
End Sub

Sub Tabelle2_Vokabelkarte_zurücksetzen()
Sheets("Tabelle2").Select
'stellt Spaltenbreite und Zeilenhöhe ein
Rows("1:16300").RowHeight = 12.75
Rows(ZeilenBereich).RowHeight = ZeilenHöhe
Columns(SpaltenBereich).ColumnWidth = SpaltenBreite
End Sub

Sub Tabelle2_Autoausfüllen()           ' (Modul 2)  Tabelle2 Automatisch ausfüllen
Set Tab2 = Sheets("Tabelle2")
Set Tab1 = Sheets("Tabelle1")
Sheets("Tabelle2").Select
'Tabellenbereich löschen
Range("A1:G3500") = Empty
Range("A1").Select
'wichtige Variable vorladen
a = 1:  b = 1:  c = 1:  x = b
z1 = Zeile_1 - 1: s1 = Spalte_1 - 1
If SpaltenBereich = "A:F" Then s1 = 0
'Schleife zum Auto ausfüllen von Tabelle1 in Tabelle2
'kopiert bis er eine leere Zelle findet  (Tabellen Ende)
Do Until Tab1.Cells(a, 1) & Tab1.Cells(a + 1, 1) = Empty
'Aussenseite Vokabelkarten
For Aussen = 1 To 3
Tab2.Cells(z1 + b, s1 + 1) = Tab1.Cells(a, 1)
Tab2.Cells(z1 + b, s1 + 6) = Tab1.Cells(a, 2)
b = b + 2:  a = a + 1
Next Aussen
'Innenseite Vokabelkarten
For Innen = 1 To 3
Tab2.Cells(z1 + c, s1 + 3) = Tab1.Cells(a, 1)
Tab2.Cells(z1 + c, s1 + 4) = Tab1.Cells(a, 2)
c = c + 2:  a = a + 1
Next Innen
Loop
'nach dem ausfüllen Druckbereich festlegen
Call Tabelle2_Druckbereich_festlegen
End Sub

Sub Tabelle2_Druckbereich_festlegen()
Dim DrAdr, ASpa, ESpa, m1, m2, z1, z2, z3, z4
Sheets("Tabelle2").Select
Call Druckbereich_löschen
On Error GoTo Feh
'End Zeilen feststellen  ("A:F" oder "B:G")
z1 = Range("A6000").End(xlUp).Row
z2 = Range("B6000").End(xlUp).Row
z3 = Range("C6000").End(xlUp).Row
z4 = Range("D6000").End(xlUp).Row
If z1 < 10 Then z1 = 0    'kleine Werte löschen
If z2 < 10 Then z2 = 0
If z3 < 10 Then z3 = 0
If z4 < 10 Then z4 = 0
m1 = z1 + z2:  m2 = z3 + z4   '2 Spalten addieren
'Zeilen Auswerten und Anfangs Adresse bilden
If Cells(1, 1) <> "" Then ASpa = "A1:": ESpa = "F" Else _
If Cells(1, 2) <> "" Then ASpa = "B1:": ESpa = "G"
'Zeilen Auswerten und End Adresse zufügen
If m1 > m2 Then DrAdr = CStr(ASpa & ESpa & m1)
If m2 > m1 Then DrAdr = CStr(ASpa & ESpa & m2)
Range(DrAdr).Select   'Druckbereich festlegen
ActiveSheet.PageSetup.PrintArea = Selection.Address
Exit Sub
'Fehlermeldung wenn kein Druckertreiber vorhanden ist
Feh:  MsgBox "Druckbereich konnte nicht festgelegt werden" & _
Chr(10) & "gefundene Druck Adresse:  '" & DrAdr & "'"
End Sub

Sub Druckbereich_löschen()
Sheets("Tabelle2").PageSetup.PrintArea = ""
End Sub