VBA Bedingtes Kopieren und Wordexport
24.08.2020 07:16:39
Dana
mittels VBA soll eine Excel-Datei ausgewertet werden. Dabei hakt es immer noch an diversen Stellen.
Alle Eingaben zu Mathe werden in der Tabelle "Mathematik", alle Eingaben zu Deutsch in der Tabelle "Deutsch", ... eingetragen.
Nun meine Fragen:
1. Wie bekomme ich es bei c16 hin, dass...
... erst wieder geprüft wird, ob die Zelle leer ist,
... dann der Inhalt NICHT "Hauswirtschaft" ist,
... um dann erst nach "Wirtschaft" zu suchen.
2. Wie ginge es (beim nächsten Mal) insgesamt kürzer/eleganter, da vieles durchnummeriert ist?
3. Was muss ich eingeben, damit manches noch mehr automatisiert wird?
In dieser Tabelle habe ich die Fächer, nach denen gesucht werden soll, manuell in VBA eingegeben.
Die Fächer, nach denen gesucht werden soll, stehen in irgendeiner Zelle drin, die mit "Q01>" beginnen.
Was muss ich an welcher Stelle eingeben, damit
a) nach diesen Fächern (automatisch) gesucht wird, die unter "Q01>" stehen?
b) die Tabellenblätter so nach den Fächern benannt werden, die unter "Q01>" stehen?
Beispiel:
Zellinhalt:
Q01>ABC => soll das Tabellenblatt ABC erzeugen und dann alle Einträge, die zusätzlich ABC enthalten in das gleichnamige Tabellenblatt kopieren.
Q01>DEFG => soll das Tabellenblatt DEFG erzeugen und dann alle Einträge, die zusätzlich DEFG enthalten in das gleichnamige Tabellenblatt kopieren.
Q01>HIJKL => Tabellenblatt HIJKL zzgl. der Einträge GHI
...
4. Das fehlt mir leider insgesamt noch:
Die Inhalte, die nun in den Fächer-Tabellen stehen, sollen nun als Textmarken in ein word-Dokument eingefügt werden. Die Textmarken im Word-Dokument sind dabei durchnummeriert.
Es sollen nun alle Einträge vom Tabellenblatt Mathematik (die in der Spalte B stehen von B1 bis B...) an die Textmarken Mathe_1 bis Mathe_... eingefügt werden.
Dabei soll allerdings zusätzlich die Word-Datei, in der die Textmarken eingefügt werden soll, manuell ausgewählt werden, sodass der Dateipfad nicht immer der gleiche ist.
Wie muss ich das realisieren?
Ich bin für eure Hilfe echt dankbar.
Soweit bin ich jetzt (als VBA Neuling, wobei ich an der ein oder anderen Stelle nicht weiß, was es macht; aber es macht, das was es soll ;-) außer bei "Wirtschaft"):
Sub Kopieren()
' Kopieren Makro
' löscht die leeren Spalten D und F (weil die ggf. leer sind)
Sheets("Daten").Select
Columns("F:F").Select
Selection.Delete Shift:=xlToLeft
Columns("D:D").Select
Selection.Delete Shift:=xlToLeft
'alles markieren, alles kopieren neue Tabelle "Hilfstabelle1" transponiert einfügen
Dim hu, mu 'Quelle: https://www.herber.de/forum/archiv/ _
1224to1228/1224691_A1_bis_letzte_verwendete_Zelle_markieren.html
With ActiveSheet
hu = .UsedRange.Columns.Count
mu = .UsedRange.Rows.Count
.Range(.Cells(1, 1), .Cells(mu, hu)).Select
'oder so
'.UsedRange.Select
'.Range(.Cells(1, 1), .Cells(1, .Cells(1, .Columns.Count).End(xlToLeft).Column)).Copy
End With
Selection.Copy
ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets. _
Count)
ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count).Name = "Hilfstabelle1"
Sheets("Hilfstabelle1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
'Hilfstabelle1: alles markieren, suche leere Zellen und lösche diese. Verschiebe die restlichen _
_
Zellen nach links
Sheets("Hilfstabelle1").Select
Dim hu2, mu2 'Quelle: https://www.herber.de/forum/archiv/ _
1224to1228/1224691_A1_bis_letzte_verwendete_Zelle_markieren.html
With ActiveSheet
hu2 = .UsedRange.Columns.Count
mu2 = .UsedRange.Rows.Count
.Range(.Cells(1, 1), .Cells(mu2, hu2)).Select
'oder so
'.UsedRange.Select
'.Range(.Cells(1, 1), .Cells(1, .Cells(1, .Columns.Count).End(xlToLeft).Column)).Copy
End With
Selection.SpecialCells(xlCellTypeBlanks).Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
'Erzeuge alle Tabellenblätter nach Fächern
'=> das wäre cool, wenn man das irgendwie auch automatisch lösen könnte
ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets. _
Count)
ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count).Name = "Mathematik"
ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets. _
Count)
ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count).Name = "Deutsch"
ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets. _
Count)
ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count).Name = "Englisch"
ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets. _
Count)
ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count).Name = "Biologie"
ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets. _
Count)
ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count).Name = "Physik"
ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets. _
Count)
ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count).Name = "Chemie"
ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets. _
Count)
ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count).Name = "Geschichte"
ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets. _
Count)
ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count).Name = "Geografie"
ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets. _
Count)
ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count).Name = "Ethik"
ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets. _
Count)
ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count).Name = "Religion"
ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets. _
Count)
ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count).Name = "Musik"
ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets. _
Count)
ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count).Name = "Kunsterziehung"
ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets. _
Count)
ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count).Name = "Sport"
ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets. _
Count)
ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count).Name = "Hauswirtschaft"
ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets. _
Count)
ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count).Name = "Technik"
ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets. _
Count)
ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count).Name = "Wirtschaft"
ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets. _
Count)
ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count).Name = "Sozialkunde"
ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets. _
Count)
ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count).Name = "Astronomie"
'Worksheets("Mathematik").Visible = False 'ausblenden
'Worksheets("Deutsch").Visible = False 'ausblenden
'Worksheets("Englisch").Visible = False 'ausblenden
'Worksheets("Biologie").Visible = False 'ausblenden
'Worksheets("Physik").Visible = False 'ausblenden
'Worksheets("Chemie").Visible = False 'ausblenden
'Worksheets("Geschichte").Visible = False 'ausblenden
'Worksheets("Geografie").Visible = False 'ausblenden
'Worksheets("Ethik").Visible = False 'ausblenden
'Worksheets("Religion").Visible = False 'ausblenden
'Worksheets("Musik").Visible = False 'ausblenden
'Worksheets("Kunsterziehung").Visible = False 'ausblenden
'Worksheets("Sport").Visible = False 'ausblenden
'Worksheets("Hauswirtschaft").Visible = False 'ausblenden
'Worksheets("Technik").Visible = False 'ausblenden
'Worksheets("Wirtschaft").Visible = False 'ausblenden
'Worksheets("Sozialkunde").Visible = False 'ausblenden
'Worksheets("Astronomie").Visible = False 'ausblenden
'Inhalte von Fachlehrern werden in Fach-Tabellen eingetragen
'gibt es für ein Fach keine Fragen, so wird die Tabelle nicht angezeigt; so sollte es _
zumindest sein ;-)
'Suche nach "Mathe" in Hilfstabelle => Kopiere in Tabelle "Mathe"
'angepasst von http://www. _
office-loesung.de/ftopic557624_0_0_asc.php
Dim lRow As Long
Dim i1 As Long 'Mathe in Mathematik eintragen
Dim i2 As Long 'Deutsch eintragen
Dim i3 As Long 'Englisch eintragen
Dim i4 As Long 'Biologie eintragen
Dim i5 As Long 'Physik eintragen
Dim i6 As Long 'Chemie eintragen
Dim i7 As Long 'Geschichte eintragen
Dim i8 As Long 'Geografie eintragen
Dim i9 As Long 'Ethik eintragen
Dim i10 As Long 'Religion eintragen
Dim i11 As Long 'Musik eintragen
Dim i12 As Long 'Kunst in Kunsterziehung eintragen
Dim i13 As Long 'Sport eintragen
Dim i14 As Long 'Hauswirtschaft eintragen
Dim i15 As Long 'Technik eintragen
Dim i16 As Long 'Wirtschaft eintragen
Dim i17 As Long 'Astronomie eintragen
Dim wks As Worksheet
Dim c1 As Range
Dim c2 As Range
Dim c3 As Range
Dim c4 As Range
Dim c5 As Range
Dim c6 As Range
Dim c7 As Range
Dim c8 As Range
Dim c9 As Range
Dim c10 As Range
Dim c11 As Range
Dim c12 As Range
Dim c13 As Range
Dim c14 As Range
Dim c15 As Range
Dim c16 As Range
Dim c17 As Range
Dim firstaddress1 As String
Dim firstaddress2 As String
Dim firstaddress3 As String
Dim firstaddress4 As String
Dim firstaddress5 As String
Dim firstaddress6 As String
Dim firstaddress7 As String
Dim firstaddress8 As String
Dim firstaddress9 As String
Dim firstaddress10 As String
Dim firstaddress11 As String
Dim firstaddress12 As String
Dim firstaddress13 As String
Dim firstaddress14 As String
Dim firstaddress15 As String
Dim firstaddress16 As String
Dim firstaddress17 As String
Application.ScreenUpdating = False 'Bildschirm wird nicht aktualisiert
Set wks = Worksheets("Hilfstabelle1")
With wks.Range("A1:A" & wks.Cells(Rows.Count, 2).End(xlUp).Row)
Set c1 = .Find(what:="Mathe", LookIn:=xlValues, lookat:=xlPart)
If Not c1 Is Nothing Then
'Worksheets("Mathematik").Visible = True 'einblenden
firstaddress1 = c1.Address
Do
i1 = i1 + 1
wks.Rows(c1.Row).Copy Worksheets("Mathematik").Cells(i1, 1)
Set c1 = .FindNext(c1)
Loop While c1.Address firstaddress1
End If
Set c2 = .Find(what:="Deutsch", LookIn:=xlValues, lookat:=xlPart)
If Not c2 Is Nothing Then
'Worksheets("Deutsch").Visible = True 'einblenden
firstaddress2 = c2.Address
Do
i2 = i2 + 1
wks.Rows(c2.Row).Copy Worksheets("Deutsch").Cells(i2, 1)
Set c2 = .FindNext(c2)
Loop While c2.Address firstaddress2
End If
Set c3 = .Find(what:="Englisch", LookIn:=xlValues, lookat:=xlPart)
If Not c3 Is Nothing Then
'Worksheets("Englisch").Visible = True 'einblenden
firstaddress3 = c3.Address
Do
i3 = i3 + 1
wks.Rows(c3.Row).Copy Worksheets("Englisch").Cells(i3, 1)
Set c3 = .FindNext(c3)
Loop While c3.Address firstaddress3
End If
Set c4 = .Find(what:="Biologie", LookIn:=xlValues, lookat:=xlPart)
If Not c4 Is Nothing Then
'Worksheets("Biologie").Visible = True 'einblenden
firstaddress4 = c4.Address
Do
i4 = i4 + 1
wks.Rows(c4.Row).Copy Worksheets("Biologie").Cells(i4, 1)
Set c4 = .FindNext(c4)
Loop While c4.Address firstaddress4
End If
Set c5 = .Find(what:="Physik", LookIn:=xlValues, lookat:=xlPart)
If Not c5 Is Nothing Then
'Worksheets("Physik").Visible = True 'einblenden
firstaddress5 = c5.Address
Do
i5 = i5 + 1
wks.Rows(c5.Row).Copy Worksheets("Physik").Cells(i5, 1)
Set c5 = .FindNext(c5)
Loop While c5.Address firstaddress5
End If
Set c6 = .Find(what:="Chemie", LookIn:=xlValues, lookat:=xlPart)
If Not c6 Is Nothing Then
'Worksheets("Chemie").Visible = True 'einblenden
firstaddress6 = c6.Address
Do
i6 = i6 + 1
wks.Rows(c6.Row).Copy Worksheets("Chemie").Cells(i6, 1)
Set c6 = .FindNext(c6)
Loop While c6.Address firstaddress6
End If
Set c7 = .Find(what:="Geschichte", LookIn:=xlValues, lookat:=xlPart)
If Not c7 Is Nothing Then
'Worksheets("Geschichte").Visible = True 'einblenden
firstaddress7 = c7.Address
Do
i7 = i7 + 1
wks.Rows(c7.Row).Copy Worksheets("Geschichte").Cells(i7, 1)
Set c7 = .FindNext(c7)
Loop While c7.Address firstaddress7
End If
Set c8 = .Find(what:="Geografie", LookIn:=xlValues, lookat:=xlPart)
If Not c8 Is Nothing Then
'Worksheets("Geografie").Visible = True 'einblenden
firstaddress8 = c8.Address
Do
i8 = i8 + 1
wks.Rows(c8.Row).Copy Worksheets("Geografie").Cells(i8, 1)
Set c8 = .FindNext(c8)
Loop While c8.Address firstaddress8
End If
Set c9 = .Find(what:="Ethik", LookIn:=xlValues, lookat:=xlPart)
If Not c9 Is Nothing Then
'Worksheets("Ethik").Visible = True 'einblenden
firstaddress9 = c9.Address
Do
i9 = i9 + 1
wks.Rows(c9.Row).Copy Worksheets("Ethik").Cells(i9, 1)
Set c9 = .FindNext(c8)
Loop While c9.Address firstaddress9
End If
Set c10 = .Find(what:="Religion", LookIn:=xlValues, lookat:=xlPart)
If Not c10 Is Nothing Then
'Worksheets("Religion").Visible = True 'einblenden
firstaddress10 = c10.Address
Do
i10 = i10 + 1
wks.Rows(c10.Row).Copy Worksheets("Religion").Cells(i10, 1)
Set c10 = .FindNext(c10)
Loop While c10.Address firstaddress10
End If
Set c11 = .Find(what:="Musik", LookIn:=xlValues, lookat:=xlPart)
If Not c11 Is Nothing Then
'Worksheets("Musik").Visible = True 'einblenden
firstaddress11 = c11.Address
Do
i11 = i11 + 1
wks.Rows(c11.Row).Copy Worksheets("Musik").Cells(i11, 1)
Set c11 = .FindNext(c11)
Loop While c11.Address firstaddress11
End If
Set c12 = .Find(what:="Kunst", LookIn:=xlValues, lookat:=xlPart)
If Not c12 Is Nothing Then
'Worksheets("Kunsterziehung").Visible = True 'einblenden
firstaddress12 = c12.Address
Do
i12 = i12 + 1
wks.Rows(c12.Row).Copy Worksheets("Kunsterziehung").Cells(i12, 1)
Set c12 = .FindNext(c12)
Loop While c12.Address firstaddress12
End If
Set c13 = .Find(what:="Sport", LookIn:=xlValues, lookat:=xlPart)
If Not c13 Is Nothing Then
'Worksheets("Sport").Visible = True 'einblenden
firstaddress13 = c13.Address
Do
i13 = i13 + 1
wks.Rows(c13.Row).Copy Worksheets("Sport").Cells(i13, 1)
Set c13 = .FindNext(c13)
Loop While c13.Address firstaddress13
End If
Set c14 = .Find(what:="Hauswirtschaft", LookIn:=xlValues, lookat:=xlPart)
If Not c14 Is Nothing Then
'Worksheets("Hauswirtschaft").Visible = True 'einblenden
firstaddress14 = c14.Address
Do
i14 = i14 + 1
wks.Rows(c14.Row).Copy Worksheets("Hauswirtschaft").Cells(i14, 1)
Set c14 = .FindNext(c14)
Loop While c14.Address firstaddress14
End If
Set c15 = .Find(what:="Technik", LookIn:=xlValues, lookat:=xlPart)
If Not c15 Is Nothing Then
'Worksheets("Technik").Visible = True 'einblenden
firstaddress15 = c15.Address
Do
i15 = i15 + 1
wks.Rows(c15.Row).Copy Worksheets("Technik").Cells(i15, 1)
Set c15 = .FindNext(c15)
Loop While c15.Address firstaddress15
End If
Set c16 = .Find(what:="Wirtschaft", LookIn:=xlValues, lookat:=xlPart)
If Not c16 Is Nothing Then
'Worksheets("Wirtschaft").Visible = True 'einblenden
firstaddress16 = c16.Address
Do
i16 = i16 + 1
wks.Rows(c16.Row).Copy Worksheets("Wirtschaft").Cells(i16, 1)
Set c16 = .FindNext(c16)
Loop While c16.Address firstaddress16
End If
Set c17 = .Find(what:="Astronomie", LookIn:=xlValues, lookat:=xlPart)
If Not c17 Is Nothing Then
'Worksheets("Astronomie").Visible = True 'einblenden
firstaddress17 = c17.Address
Do
i17 = i17 + 1
wks.Rows(c18.Row).Copy Worksheets("Astronomie").Cells(i17, 1)
Set c17 = .FindNext(c17)
Loop While c17.Address firstaddress17
End If
End With
Application.ScreenUpdating = True 'Bildschirm wird aktualisiert
End Sub