EXCEL+VBA: Filtern + Kopieren + Formeln einfügen

Question

Moin zusammen,



ich habe mich an einem Projekt zur Datenbearbeitung
gewagt und
komme nun an meine Grenzen. Daher hier nun mein
Bitte um Hilfe.
Das Projekt sieht wie folgt aus:

Ziel/Ergebnis:

1. Aus einem Excel-Sheet sollten festgelegte Spalten
(konstant) und
nach definierten [xurl=https://supportnet.de/faqsthread/888|Summewenn und Zählenwenn mit mehreren Kriterien mit Excel]Kriterien[/url] bestimmte Zeilen (variabel) in
ein anders
bestehendes Excel-Sheet kopiert werden.

2. In vordefinierten Spalten sollten
Berechnungen/Formeln für alle
Zeilen eingefügt werden.



Ausgangslage:

Es besteht ein Datensatz in einem Excel-Sheet mit
folgender Struktur:

- Spaltenanzahl ist immer konstantist (A bis BD)

- keine Spaltenbeschriftung, d.h. Datensatz beginnt ab
der 1. Zeile

- Zeilenanzahl ist unterschiedlich

- Datensatz-Formate:

  Spalten B, D, E, S und T: Nummerisch

  Spalte C: Datum im Format: TT.MM.JJJJ

  Spalte F, I, M, O und R: Text

  Spalten K und L: Währungswerte ( in EUR)



Aufgabe:

1. Daten werden per VBA-Skript in ein bestehendes
Excel-Sheet
(nachfolgend genannt: "Sheet 2") von einer externen
Quelle (Excel-
Datei) eingelesen. => Teilprojdekt abgeschlossen, VBA
läuft
einwandfrei :-)

2. Für die weitere Verwendung der Daten ist nicht der
gesamte
Datensatz notwendig. Zur Reduktion der Datengröße
sollten nur
Zeilen in ein anderes, bestehendes Sheet (nachfolgend
genannt:
"Sheet 1") kopiert werden, die bestimmte Bedingungen
erfüllen.
Nachfolgende Kriterien gelten:

a.) Spalte B und E: Inhalt: Zehlenwerte mit einer Länge
von 5 bis 7
Zeichen => 1.+2. Auswahlkriterium: Zeilen Auswählen die
nicht
gleichzeitig (ungleich) das Kriterium erfüllen 1.) eine
Zeichenlänge von
6 und 2.) mit 9 zu beginnend.

b.) Spalte B: Inhalt: (siehe oben zu a.) => 3.
Auswahlkriterium:
Auswahlkriterium: Zeilen Auswählen die nicht gleichzeitig
(ungleich)
das Kriterium erfüllen 1.) eine Zeichenlänge von 7 und 2.)
mit 7 zu
beginnend.

c.) relevante Spalte sind B bis F, I bis M, O und R bis T

3. Kopiere Datensatz der die unter Nr. 2 genannten
Kriterien (siehe
oben) erfüllt in "Sheet 1" ab der 2ten Zeile (Zeile 1 ist für
Überschrift
reserviert)

4. Duchführung von Berechnungen in vordefinierten
Spalten:

    Die zu kopierenden Daten aus 3. sind entweder bereits
in die
vordefinierten Spalten zu kopieren, oder ein Sheet 1 zu
kopieren und
sodann Spalten einzufügen. Zu berücksichtigen ist
jeweils, dass am
Ende die vordefinierte Spaltenbeschriftung vorhanden ist.

   Gem. dem anliegenden Beispiel sollten bestimmte
Berechnungen
mit Variablen und bedingten Formeln durchgeführt
werden.



Musterdatei ist verfügbar über folgenden Link:

Link: https://workupload.com/file/p8Vyb2s

Passwort: VBA2017

Ablaufdatum: 11. Sept. 2017



Vielen Dank bereits im Voraus!

Beginnereginner

Answer 1

Ergänzung: Die Zeilenanzahl beträgt i.d.R. 50.000 bis 200.000

Answer 2

Hallo Beginner,

wie ist das mit Punkt 2a? Soll nur kopiert werden wenn in Spalte B UND Spalte E jeweils eins der beiden Kriterien erfüllt ist. Oder soll nur für eine der beiden Spalten diese Prüfung stattfinden, und was im Gegenkonto steht ist dann egal? Für ersteren Fall, probier mal folgenen Code:

[code]Sub DatenKopieren()

Dim Kopieren As Byte

Blatt2 = "Sheet 2 (originale Daten)"
Blatt1 = "Sheet 1"

Sheets(Blatt1).Select
  'Spaltenüberschriften füllen
  Range("A1:AC1").WrapText = True
  Range("A1:AC1") = Array( _
  "CALC.FIELD Kontenklasse Buchung", "CALC.FIELD Kreditor/" & Chr(10) & "Debitor", "Konto", "Datum", _
  "CALC.FIELD Posting Calender Day", "CALC.FIELD Posting Date on Weekend", "Buchungsschlüssel", _
  "CALC.FIELD Kontenklassen Gegenkonto", "CALC.FIELD Kreditor/" & Chr(10) & "Debitor", "Gegenkonto", _
  "Buchungstext", "Belegfeld 1", "Belegfeld 2", "Sollbetrag", "Habenbetrag", "S/H", "CALC.FIELD Betrag", _
  "Währung", "CALC.FIELD Betrag konvertiert in text", "Buchungs-stapel", "Buchungsnummer", "KSt", _
  "CALC.FIELD Buchungsjahr lt. Buchungsstapel", "CALC.FIELD Buchungsmonat lt. Buchungsstapel", _
  "CALC.FIELD Buchungsmonat lt. erfaßte Datum", "CALC.FIELD Abweichung Buchngsmonat lt. Buchungsstapel vs. Erfaßte Datum", _
  "CALC.FIELD Kombination Value Konto & Betrag", "CALC.FIELD Marker Identifizierung Gegenbuchungen zur Eleminierung", _
  "CALC.FIELD Buchungsstapel & Buchungs-Nr.")
  
  
  
  'Spaltenbreiten setzen
  Columns("A:C").ColumnWidth = 8.43
  Columns("G:I").ColumnWidth = 8.43
  Columns("P").ColumnWidth = 8.43
  Columns("R").ColumnWidth = 8.43
  Columns("U:V").ColumnWidth = 8.43
  Columns("D:E").ColumnWidth = 9.43
  Columns("F").ColumnWidth = 16.14
  Columns("J").ColumnWidth = 13.57
  Columns("K").ColumnWidth = 52
  Columns("L:O").ColumnWidth = 11.86
  Columns("Q:T").ColumnWidth = 12.86
  Columns("S").ColumnWidth = 19
  Columns("W:AA").ColumnWidth = 19
  Columns("AB").ColumnWidth = 34.29
  Columns("AC").ColumnWidth = 14.14
  
  'Formate setzen
  Columns("D").NumberFormat = "DD.MM.YYYY"
  Columns("Q").NumberFormat = "#,##0.00"
  Columns("S").NumberFormat = "#,##0.00"

Sheets(Blatt2).Select
  lastRow = Cells(Rows.Count, 3).End(xlUp).Row
  z = 1
   
  For i = 1 To lastRow
    Kopieren = 0
    'Betrachtung von Spale B
    Select Case Len(Cells(i, 2))
    Case 5
      Kopieren = Kopieren + 1
    Case 6
      If Not Left(Cells(i, 2), 1) = "9" Then Kopieren = Kopieren + 1
    Case 7
      If Not Left(Cells(i, 2), 1) = "7" Then Kopieren = Kopieren + 1
    End Select
  
    'Betrachtung von Spale E
    Select Case Len(Cells(i, 5))
    Case 5, 7
      Kopieren = Kopieren + 1
    Case 6
      If Not Left(Cells(i, 5), 1) = "9" Then Kopieren = Kopieren + 1
    End Select
  
    If Kopieren = 2 Then
      With Sheets(Blatt1)
        z = z + 1
        'Datensatz kopieren, wenn zutreffend
        .Cells(z, 3) = Cells(i, 2) 'Spalte B kopieren nach Spalte C
        .Cells(z, 4) = Cells(i, 3) 'Spalte C kopieren nach Spalte D
        .Cells(z, 7) = Cells(i, 4) 'Spalte D kopieren nach Spalte G
        .Cells(z, 10) = Cells(i, 5) 'Spalte E kopieren nach Spalte J
        .Cells(z, 11) = Cells(i, 6) 'Spalte F kopieren nach Spalte K
        .Cells(z, 12) = Cells(i, 9) 'Spalte I kopieren nach Spalte L
        .Cells(z, 13) = Cells(i, 10) 'Spalte J kopieren nach Spalte M
        .Cells(z, 14) = Cells(i, 11) 'Spalte K kopieren nach Spalte N
        .Cells(z, 15) = Cells(i, 12) 'Spalte L kopieren nach Spalte O
        .Cells(z, 16) = Cells(i, 13) 'Spalte M kopieren nach Spalte P
        .Cells(z, 18) = Cells(i, 15) 'Spalte O kopieren nach Spalte R
        .Cells(z, 20) = Cells(i, 18) 'Spalte R kopieren nach Spalte T
        .Cells(z, 21) = Cells(i, 19) 'Spalte S kopieren nach Spalte U
        .Cells(z, 22) = Cells(i, 20) 'Spalte T kopieren nach Spalte V
      End With
    End If
  Next i

  With Sheets(Blatt1)
  'Formeln setzen
  .Cells(2, 1).FormulaLocal = "=WENN(B2="""";WENN(LÄNGE(C2)=5;0;WERT(LINKS(C2;1)));B2)"
  .Cells(2, 2).FormulaLocal = "=WENN(LÄNGE(C2)=7;WENN(LINKS(C2;1)=""7"";""Kreditor"";WENN(LINKS(C2;1)=""1"";""Debitor"";WENN(LINKS(C2;1)=""2"";""Debitor"")));"""")"
  .Cells(2, 5).FormulaLocal = "=TAG(D2)"
  .Cells(2, 6).FormulaLocal = "=WAHL(WOCHENTAG(D2);""Sun"";""Mon"";""Tue"";""Wed"";""Thu"";""Fri"";""Sat"")"
  .Cells(2, 8).FormulaLocal = "=WENN(I2="""";WENN(LÄNGE(J2)=5;0;WERT(LINKS(J2;1)));I2)"
  .Cells(2, 9).FormulaLocal = "=WENN(LÄNGE(J2)=7;WENN(LINKS(J2;1)=""7"";""Kreditor"";WENN(LINKS(J2;1)=""1"";""Debitor"";WENN(LINKS(J2;1)=""2"";""Debitor"")));"""")"
  .Cells(2, 17).FormulaLocal = "=+N2-O2"
  .Cells(2, 19).FormulaLocal = "=TEXT(Q2;""0,00"")"
  .Cells(2, 23).FormulaLocal = "=WERT(RECHTS(LINKS(T2;7);4))"
  .Cells(2, 24).FormulaLocal = "=LINKS(T2;2)"
  .Cells(2, 25).FormulaLocal = "=MONAT(D2)"
  .Cells(2, 26).FormulaLocal = "=X2-Y2"
  .Cells(2, 27).FormulaLocal = "=C2&Q2"
  .Cells(2, 28).FormulaLocal = "=T2&""-""&U2&""-""&WENN(Q2<=0;-Q2;Q2)&""-""&C2*J2"
  .Cells(2, 29).FormulaLocal = "=T2&U2"
  
  'Formeln nach unten ziehen
   lr2 = .Cells(Rows.Count, 4).End(xlUp).Row
  .Range("A2:B2").AutoFill .Range("A2:B" & lr2), xlFillDefault
  .Range("E2:F2").AutoFill .Range("E2:F" & lr2), xlFillDefault
  .Range("H2:I2").AutoFill .Range("H2:I" & lr2), xlFillDefault
  .Range("Q2").AutoFill .Range("Q2:Q" & lr2), xlFillDefault
  .Range("S2").AutoFill .Range("S2:S" & lr2), xlFillDefault
  .Range("W2:AC2").AutoFill .Range("W2:AC" & lr2), xlFillDefault

  .Range("B1").AutoFilter 'Filter setzen
  End With
  
  Sheets(Blatt1).Select
  
End Sub[/code]Punkt 1 hast du ja bereits gelöst, daher hab ich diesen Teil weggelassen. Und die Formeln hab ich aufgrund der Menge mal direkt in den Code kopiert. Deine Addon-formel _xlfn.NUMBERVALUE() hab ich dabei durch WERT() ersetzt, da nicht jeder dieses Addon zur Verfügung hat.

Gruß Mr. K.