Microsoft Excel

Herbers Excel/VBA-Archiv

VBA Bedingtes Kopieren und Wordexport

Betrifft: VBA Bedingtes Kopieren und Wordexport von: Dana Wagner
Geschrieben am: 24.08.2020 07:16:39

Liebe Forumsmitglieder,


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

Betrifft: AW: VBA Bedingtes Kopieren und Wordexport
von: Oberschlumpf
Geschrieben am: 24.08.2020 07:29:25

Hi Dana,

meinst du diesen Beitrag wirklich ernst?!

Ne XL-Bsp-Datei per Upload , die all das zeigt, was du hier versuchst, zu erklären, könnte besser helfen.

Ciao
Thorsten

Betrifft: AW: VBA Bedingtes Kopieren und Wordexport
von: Dana Wagner
Geschrieben am: 24.08.2020 23:23:47

Irgendwie schaffe ich es nicht etwas hochzuladen?!? :-(

Betrifft: AW: VBA Bedingtes Kopieren und Wordexport
von: Dana
Geschrieben am: 25.08.2020 00:12:04

Hab es hinbekommen...



Warum macht es einen Unterschied, welchen Browser ich benutze zum Hochladen???





https://www.herber.de/bbs/user/139821.xlsm




https://www.herber.de/bbs/user/139822.doc

Betrifft: AW: VBA Bedingtes Kopieren und Wordexport
von: Oberschlumpf
Geschrieben am: 25.08.2020 05:39:50

Hi Dana,

danke für die Bsp-Dateien.
Aber sorry, für mich ist das zu viel Durcheinander.

In der XL-Datei sind nun gar keine Makros mehr drin.

Ich steig da nicht durch.

Aber vielleicht kann dir ja jemand anderes helfen.

Ciao
Thorsten

Beiträge aus dem Excel-Forum zum Thema "VBA Bedingtes Kopieren und Wordexport"