Office: (Office 365) Makros nach wenn dann prüfen und durchführen

Ich arbeite zurzeit an einer Übersichtstabelle, aus der ich Informationen aus verschiedene Excelformulare entnehme. Da aber es ziemlich zeitaufwendig ist, jede einzelne Angabe manuell auf die Übersicht zu übertragen, dachte ich mir, dass ich vielleicht dazu ein Makro aufzeichnen kann welche ich dann mehrmals wiederhole, da alle Informationen in den Umfragen an den identischen Zellen zu finden sind.

Hierzu bräuchte ich aber Hilfe bei der Erstellung einer Bedingung, wann dieses Makro ausgeführt werden sollte: das heißt, wenn die Zeile „Bezeichnung“ ungleich null ist, dann Zeile usw. auf Übersicht kopieren und dann auf nächste Zeile springen und nochmal „wenn dann“ Bedingung ausführen bis man das Ende des Formulars erreicht hat, welche max. 50 Einträge haben kann i.d.R sind es zwischen 2 und 15. Da diese aber in Reihenfolge ausgefüllt wurden, sind, wenn der 4 Eintrag leer ist, keine weiteren Einträge vorhanden (von 5 bis 50). Ich gehe davon aus, dass man hier dann mit ein Index arbeiten muss der i+1 immer einsetzt, solange die Zelle ausgefüllt ist.

Könnten mir jemand helfen, wie so eine komplexe Bedingung in VBA auszusehen kann?

Für jegliche Hinweise wäre ich sehr dankbar!
Grüße
Mariano

 

Hallo Mariano,

ein ähnliches VBA-Problem habe gerade für User @CharlotteK programmiert. Ich nehme an, mit ein paar Anpassungen müsste dieses Makro auch für dich genügen.
Hier der Link:
(Office 2016) - Excel VBA - Zellinhalte anhand von Spaltenüberschriften finden und kopieren

 

Hallo Anton,
danke für die schnelle Rückmeldung. Ich habe mir es mal angeschaut und in der Tat scheint es in derselben Richtung zu gehen. Aber falls die Quelle sich in einer anderen Datei befindet (siehe beide Dateien) in welcher teil der Formel müsste dann der Dateienpfad eingefügt werden damit Excel es bei der Ausführung erkennt?

 

Hallo,

ich habe deine beiden Dateien modifiziert und im Anhang 3 Dateien angefügt, die du
1) alle 3 in ein und dasselbe Verzeichnis speichern musst.
2) Dann öffnest du die Excel-Arbeitsmappe "marflores_Übersicht.xlsm". Diese enthält das Arbeitsblatt "Projektübersicht", in dem die strukturierte Tabelle "tabQuellmappen" und der blaue Button "Hochschul-Projektnummern importieren" enthalten sind.

Dabei enthält die Tabelle "tabQuellmappen" die Namen der beiden Datendateien, die mehrere Arbeitsblätter enthalten (können). Die Struktur dieser Arbeitsblätter muss überall identisch sein, so wie du sie mir vorgegeben hast in deiner Datei "FORMULAR.XLSX". Diese Tabelle kannst du nach Belieben mit weiteren Dateinamen ergänzen, wenn du solche weiteren Dateien importieren willst.

Durch Klick auf den blauen Button werden die Dateien der Tabelle "tabQuellmappen" der Reihe nach geöffnet und der Inhalt aus allen in ihnen enthaltenen Arbeitsblättern in die beiden Spalten A+B des Arbeitsblattes "Projektübersicht" importiert.

Der Button ist mit dem Makro "Hochschul_Projektnummern()" in einem allgemeinen VBA-Codemodul verknüpft und sieht wie folgt aus:

Code:

Option Explicit

Sub Hochschul_Projektnummern()

  Dim WbQ As Workbook      'Quell-Arbeitsmappe
  Dim WbZ As Workbook      'Ziel-Arbeitsmappe (=DieseArbeitsmappe)
 
  Dim WsQ As Worksheet     'Quell-Arbeitsblatt
  Dim WsZ As Worksheet     'Ziel-Arbeitsblatt (=Projektübersicht)
 
  Dim rwQ As ListRow       'Satz Tabelle "tabQuellmappen"
  Dim PfadDateiQ As String 'Pfad+Dateiname einer Quellarbeitsmappe
 
  Dim ZlQ As Long          'Quell-Zeilennummer
  Dim ZlZ As Long          'Ziel-Zeilennummer

  Application.ScreenUpdating = False

  Set WbZ = ThisWorkbook                          'Ziel-Arbeitsmappe (=DieseArbeitsmappe)
  Set WsZ = WbZ.Worksheets("Projektübersicht")    'Ziel-Arbeitsblatt
 
  ZlZ = 2
  For Each rwQ In WsZ.ListObjects("tabQuellmappen").ListRows 'Liste "QuellmappenNamen"
 
      PfadDateiQ = WbZ.Path & "\" & rwQ.Range.Cells(1)
      Set WbQ = Workbooks.Open(Filename:=PfadDateiQ)     'Quell-Arbeitsmappe

      For Each WsQ In WbQ.Worksheets                     'Quell-Arbeitsblätter
         With WsQ
      
             For ZlQ = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
                .Cells(ZlQ, "D").Copy Destination:=WsZ.Cells(ZlZ, "A") 'Hochschule
                .Cells(ZlQ, "E").Copy Destination:=WsZ.Cells(ZlZ, "B") 'Projektnummer
                ZlZ = ZlZ + 1
             Next ZlQ
          
         End With
      Next WsQ
    
      WbQ.Close SaveChanges:=False
    
  Next rwQ

  WsZ.Activate
  WsZ.Range("A1").Activate
  Application.ScreenUpdating = True

End Sub

 

Lieber Anton,
perfekt damit hast du mir wirklich ein ganzes Stück weitergeholfen. Nur eine letzte Frage: d.h. wenn ich weitere Dateien hinzufügen will, muss ich diese eingrenzen (wie du das bei der Erstellung von tabQuellmappen gemacht hast) -> bei "Pfad+Dateienname einer Quellarbeitsmappe" hinzufügen + die Quelldatei muss dann immer gleichzeitig geöffnet sein damit diese identifiziert wird, richtig?
VG

 

Hallo,

musst du diese Dateinamen (ohne Pfad, aber mit Dateierweiterung) als weitere Zeile an die strukturierte Tabelle "tabQuellmappen" anfügen. Diese Zusatzzeile(n) werden dann automatisch Bestandteil der strukt.Tabelle - man kann dies leicht feststellen, da sich diese Zusatzzeile im Stil der Tabelle einfärbt (Zebra-Streifen).

ich weiß leider nicht, was du damit meinst.

Wieso soll die Quelldatei geöffnet sein - wo soll diese identifiziert werden - ich verstehe auch hier nicht, was du meinst.

 

Lieber Anton,
jetzt habe ich auch endlich verstanden wie das von der Logik funktioniert. Sorry, dachte man müsste im Code immer schriftlich verweisen, welche Dateien praktisch übernommen werden müssen. Hätte nicht gedacht das man einen Ort festlegen kann, wo sich dann alle Dateien befinden, wie du es ja gemacht hast. Das macht es deutlich einfacher zu erweitern je nach Anzahl der eingefügte Formulare.
Dafür will ich mich herzlich bedanken, das erspart mir wirklich Unmengen an stunden die ich verloren hätte, wenn ich die Dateien manuell kopieren würde!
Beste Grüße
Mariano

 

Hallo Anton,
eine letzte frage habe ich noch wo ich leider nicht vorankomme. Weißt du wie ich deine Codierung so anpassen kann, dass nur gewisse Spalten übertragen werden ab eine gewisse Zeile?
Konkret will ich die Spalte C und D vom Blatt "Informationen" übertragen und zwar erst ab Zeile 5. Ich vermutete es geht mit den folgenden Befehl, leider war aber die Syntax falsch und ich weiß nicht ganz woran es liegt:
.Worksheets("Informationen").Cells(ZlQ("C5")).Copy Destination:=WsZ.Cells(ZlZ, "A") 'Studiengang
.Worksheets("Informationen").Cells(ZlQ("D5")).Copy Destination:=WsZ.Cells(ZlZ, "B") 'Fachrichtung

Die Anwendung auf der Datei was du mir zugesendet hast bleibt ja eigentlich genauso wie es du mir ja geschickt hast.
Danke im voraus!

 

Hallo,

da musste ich eine Reihe von Änderungen am Makro durchführen:

Code:

Option Explicit

Sub Hochschul_Projektnummern()

  Dim WbQ As Workbook      'Quell-Arbeitsmappe
  Dim WbZ As Workbook      'Ziel-Arbeitsmappe (=DieseArbeitsmappe)
 
  Dim WsQ As Worksheet     'Quell-Arbeitsblatt
  Dim WsZ As Worksheet     'Ziel-Arbeitsblatt (=Projektübersicht)
 
  Dim rwQ As ListRow       'Satz Tabelle "tabQuellmappen"
  Dim PfadDateiQ As String 'Pfad+Dateiname einer Quellarbeitsmappe
 
  Dim ZlQ As Long          'Quell-Zeilennummer
  Dim ZlZ As Long          'Ziel-Zeilennummer

  Application.ScreenUpdating = False

  Set WbZ = ThisWorkbook                          'Ziel-Arbeitsmappe (=DieseArbeitsmappe)
  Set WsZ = WbZ.Worksheets("Projektübersicht")    'Ziel-Arbeitsblatt
 
  ZlZ = 2                              'anfängliche Zeilennummer im Ziel-Arbeitsblatt
  For Each rwQ In WsZ.ListObjects("tabQuellmappen").ListRows 'Liste "QuellmappenNamen"
 
      PfadDateiQ = WbZ.Path & "\" & rwQ.Range.Cells(1)
      Set WbQ = Workbooks.Open(Filename:=PfadDateiQ)     'Quell-Arbeitsmappe

      For Each WsQ In WbQ.Worksheets                     'Liste Quell-Arbeitsblätter
         With WsQ
           If .Name = "Informationen" Then               'Nur für Quellblatt "Informationen"
             For ZlQ = 5 To .Cells(Rows.Count, "D").End(xlUp).Row
                .Cells(ZlQ, "C").Copy Destination:=WsZ.Cells(ZlZ, "A") 'Bez.Studiengang
                .Cells(ZlQ, "D").Copy Destination:=WsZ.Cells(ZlZ, "B") 'Fachrichtung
                ZlZ = ZlZ + 1
             Next ZlQ
           End If
         End With
      Next WsQ
   
      WbQ.Close SaveChanges:=False
   
  Next rwQ

  WsZ.Activate
  WsZ.Range("A1").Activate
  Application.ScreenUpdating = True

End Sub

Dieses Makro kopieren und dein bisheriges Makro damit ersetzen.

 

Hallo,
wow das ist wirklich sehr beeindruckend, danke dir für die große Hilfe, dadurch hat sich das ganze natürlich gelöst.
VG!