Microsoft Excel

Herbers Excel/VBA-Archiv

Daten zentral zusammenschreiben | Herbers Excel-Forum


Betrifft: Daten zentral zusammenschreiben von: Steve
Geschrieben am: 07.01.2010 15:29:51

Hi,

ich glaube ich brauche nochmals eure VBA-Kenntnisse. Folgende Tabelle:

https://www.herber.de/bbs/user/67045.xlsx

Das Skript müsste folgendes erledigen:
1. Prüfe alle Tabellenblätter, die mit "VP" beginnen
2. Vergleiche "Letztes Versanddatum" und "letztes Änderungsdatum"
3. wenn letztes Änderungsdatum größer dann kopiere Projektname
4. wenn letztes Änderungsdatum größer dann die jeweilige Zeile mit Name, ASP, Tel Allg, Tel ASP

Kann man so etwas machen oder geht das vielleicht auch irgendwie per FOrmel?

LG

Steve

  

Betrifft: AW: Daten zentral zusammenschreiben von: fcs
Geschrieben am: 08.01.2010 02:36:17

Hallo Steve,

die Formeln zur Übernahme wären ziemlich kompliziert.
Kannst ja mal auf http://www.excelformeln.de/formeln.html?gruppe=3 prüfen, ob dort was passendes zu finden ist. Gibt etwas kompliziertes zusammengesetzt aus INDEX, KKLEINSTE, WENN und ZEILE.

Hier meine Makro-Lösung, die auf die von dir angelegten Tabellen(Listen)-Objekte in den Tabellenblättern zugeschnitten ist.

Gruß
Franz

Sub Listenabgleich()
  Dim wksVP As Worksheet, oListeVersP As ListObject, sProjekt As String
  Dim wksVersand As Worksheet, oListeVers As ListObject
  Dim datLetzterVersand As Date, ZeileVers As Long, ZeileVP As Long, Zeile As Long
  
  'Objekte und Infos im Blatt Katalogversendung
  Set wksVersand = Worksheets("Katalogversendung")
  Set oListeVers = wksVersand.ListObjects(1)
  datLetzterVersand = wksVersand.Range("B1").Value
  
  'Letzte Zeile mit Daten im Bereich der Katalogversand-Daten
  With oListeVers.DataBodyRange
    ZeileVers = 0
    For Zeile = .Rows.Count To 1 Step -1
      If Not IsEmpty(.Cells(Zeile, 1)) Then
        ZeileVers = Zeile
        Exit For
      End If
    Next
  End With
  
  'VP-Blätter abarbeiten
  Application.ScreenUpdating = False
  For Each wksVP In ActiveWorkbook.Worksheets
    'Ersten beiden Zeichen des Blattnamens prüfen
    If Left(wksVP.Name, 2) = "VP" Then
      'Listen-Objekt setzen
      Set oListeVersP = wksVP.ListObjects(1)
      'Projektname auslesen
      sProjekt = wksVP.Range("B1").Text
      With oListeVersP.DataBodyRange
        'Zeilen in Liste abarbeiten
        For ZeileVP = 1 To .Rows.Count
          'Vergleich Änderungsdatum mit letztem Versanddatum
          If datLetzterVersand < .Cells(ZeileVP, 9) Then
            'Zeilenzähler erhöhen
            ZeileVers = ZeileVers + 1
            'Prüfen, ob Zähler größer als Datenbereich der Liste/Tabelle im Versandblatt
            If ZeileVers > oListeVers.DataBodyRange.Rows.Count Then
              'Liste/Tabelle um eine Zeile vergrößern
              oListeVers.ListRows.Add
            End If
            'Daten übertragen
            oListeVers.DataBodyRange.Cells(ZeileVers, 1) = sProjekt
            oListeVers.DataBodyRange.Cells(ZeileVers, 2) = .Cells(ZeileVP, 1) 'Firma-Name
            oListeVers.DataBodyRange.Cells(ZeileVers, 3) = .Cells(ZeileVP, 2) 'Firma ASP
            oListeVers.DataBodyRange.Cells(ZeileVers, 4) = .Cells(ZeileVP, 6) 'Info-Brief
            oListeVers.DataBodyRange.Cells(ZeileVers, 5) = .Cells(ZeileVP, 7) 'Info-Mail
            oListeVers.DataBodyRange.Cells(ZeileVers, 6) = .Cells(ZeileVP, 9) 'Änderung
          End If
        Next
      End With
    End If
  Next
  Application.ScreenUpdating = True
End Sub



  

Betrifft: AW: Daten zentral zusammenschreiben von: Steve
Geschrieben am: 09.01.2010 13:54:44

Prima funktioniert sehr gut. Ich habe einen Punkt vergessen. Kann man noch eine Überprüfung einbauen, dass wenn ein Kreuz bei Infomaterial erhalten drin ist diese Zeile übersprungen wird, da man sonst das Problem hat (ich habe in der echten Tabelle noch mehr Spalten dahinter), dass bei einem neueren Aktualisierungsdatum auch die Zeile nochmals wiedergegeben wird.



Vielen Dank im Voraus.


  

Betrifft: AW: Daten zentral zusammenschreiben von: Steve
Geschrieben am: 09.01.2010 13:55:44

habe vergessen Frage als noch offen zu markieren, sorry.


  

Betrifft: AW: Daten zentral zusammenschreiben von: Steve
Geschrieben am: 09.01.2010 14:18:02

Was auch noch nicht so richtig funktioniert. er soll pro Zeile abprüfen, ob auch tatsächlich ein Kreuz bei Infomaterial per Mail oder Post drin ist, wenn nicht muss die Zeile übersprungen werden. So wie es jetzt ist, kopiert er alles, sobald er etwas gefunden hat.


  

Betrifft: AW: Daten zentral zusammenschreiben von: fcs
Geschrieben am: 10.01.2010 00:41:23

Hallo Steve,

ich jetzt auch noch herausgefunden, das man bei Listen-Objekten, die Spalten auch über den Spaltentitel ansprechen kann. Deshalb hier das Makro überarbeitet inkl. der zusätzlichen Prüfungen auf "x" in bestimmten Spalten.

Gruß
Franz

Sub Listenabgleich1()
  Dim wksVP As Worksheet, oListeVP As ListObject, sProjekt As String
  Dim wksVersand As Worksheet, oListeVersand As ListObject
  Dim rngVersand As Range
  Dim SpalteVers As ListColumns, SpalteVP As ListColumns
  Dim datLetzterVersand As Date
  Dim ZeileVers As Long, ZeileVP As Long, Zeile As Long
  
  'Objekte und Infos im Blatt Katalogversendung
  Set wksVersand = Worksheets("Katalogversendung")
  Set oListeVersand = wksVersand.ListObjects(1)
  Set SpalteVers = oListeVersand.ListColumns
  Set rngVersand = oListeVersand.DataBodyRange
  datLetzterVersand = wksVersand.Range("B1").Value
  
  'Letzte Zeile mit Daten im Bereich der Katalogversand-Daten
  With rngVersand
    ZeileVers = 0
    For Zeile = .Rows.Count To 1 Step -1
      If Not IsEmpty(.Cells(Zeile, SpalteVers("Projekt").Index)) Then
        ZeileVers = Zeile
        Exit For
      End If
    Next
  End With
  
  'VP-Blätter abarbeiten
  Application.ScreenUpdating = False
  For Each wksVP In ActiveWorkbook.Worksheets
    'Ersten beiden Zeichen des Blattnamens prüfen
    If Left(wksVP.Name, 2) = "VP" Then
      'Listen-Objekt setzen
      Set oListeVP = wksVP.ListObjects(1)
      Set SpalteVP = oListeVP.ListColumns
      'Projektname auslesen
      sProjekt = wksVP.Range("B1").Text
      With oListeVP.DataBodyRange
        'Zeilen in Liste abarbeiten
        For ZeileVP = 1 To .Rows.Count
          'Vergleich Änderungsdatum mit letztem Versanddatum
          If datLetzterVersand < .Cells(ZeileVP, SpalteVP("Datum Änderung").Index) Then
            'Prüfen, ob X bei "Infomaterial erhalten""
            If LCase(.Cells(ZeileVP, SpalteVP("Infomaterial erhalten?").Index)) = "x" Then
              'Zeile überspringen
            Else
              'Prüfen, ob X bei "per Post" oder "e-Mail"
              If LCase(.Cells(ZeileVP, SpalteVP("Infomaterial per Post").Index)) = "x" _
                Or LCase(.Cells(ZeileVP, SpalteVP("Infomaterial per Mail").Index)) = "x" Then
              'Zeilenzähler erhöhen
              ZeileVers = ZeileVers + 1
              'Prüfen, ob Zähler größer als Datenbereich der Liste/Tabelle im Versandblatt
              If ZeileVers > rngVersand.Rows.Count Then
                'Liste/Tabelle um eine Zeile vergrößern
                oListeVersand.ListRows.Add
                Set rngVersand = oListeVersand.DataBodyRange
              End If
              'Daten übertragen
              rngVersand.Cells(ZeileVers, SpalteVers("Projekt").Index) = sProjekt
              rngVersand.Cells(ZeileVers, SpalteVers("Firmenname").Index) = _
                    .Cells(ZeileVP, SpalteVP("Firmenname").Index)
              rngVersand.Cells(ZeileVers, SpalteVers("ASP-Name").Index) = _
                    .Cells(ZeileVP, SpalteVP("ASP-Name").Index)
              rngVersand.Cells(ZeileVers, SpalteVers("Infomaterial per Post").Index) = _
                    .Cells(ZeileVP, SpalteVP("Infomaterial per Post").Index)
              rngVersand.Cells(ZeileVers, SpalteVers("Infomaterial per Mail").Index) = _
                    .Cells(ZeileVP, SpalteVP("Infomaterial per Mail").Index)
              rngVersand.Cells(ZeileVers, SpalteVers("Datum Änderung").Index) = _
                    .Cells(ZeileVP, SpalteVP("Datum Änderung").Index)
              End If
            End If
          End If
        Next
      End With
    End If
  Next
  Application.ScreenUpdating = True
End Sub