VBA Excel: wenn Bedingungen erfüllt sind, dann Zeilen in anderes Excel-File schreiben

Question

Hallo,

ich möchte aus einem File (WbDatei1; Sheet1), welches über 20000 Zeilen hat, wenn die Bedingungen stimmen div. Daten auslesen und in ein anderes File (WbDatei2; Sheet2) lesen. Das Sheet2 hat eine fixe Struktur und darf nicht verändert werden.

Im Sheet1 sind auch die Lieferzeiträume "von" und "bis" enthalten. Leider stimmen diese Daten nicht mit dem Abrechnungszeitraum überein. Deshalb wird über die UserForm das "DateFrom" und "DateTo" zusätzlich abgefragt und mit den Lieferzeiträumen aus Sheet1 verglichen.

Wenn die Bedingungen (pro Kunde) stimmen, werden die Daten in das Sheet2 gelesen. Kunde 1 Schweiz= Sheet2 Zeile 25-55, Kunde 1 Deutschland= Sheet2 Zeile 65 bis 95, Kunde 2 Schweiz=Sheet2 ab Zeile 105 usw.

Lieder erhalte ich folgende Meldung: Fehler beim Kompilieren: Prozedur zu gross

Wie kann ich das vereinfachen?

Nachfolgend findet ihr eine Code-Auszug:
Sub Fakturierungsbeleg()

Dim sPfad, sPfad1 As String       ' der Ordner-Pfad der Excel-Mappen
Dim sDatei, sDatei1 As String     ' die zu beschreibende Datei und zu speichernde Datei
Dim WbDatei1 As Workbook       ' Quelle
Dim WbDatei2 As Workbook       ' Ziel
Dim lngLZeile1, lngLZeile2 As Long
Dim DateFrom As Date                ' Lieferdatum von
Dim DateTo As Date                    ' Lieferdatum bis
Dim MonthLieferung As String     ' Monatsname vom Lieferdatum
Dim sLieferzeitraum As String
Dim strDateiname As String

Set WbDatei1 = ActiveWorkbook   'Quelle Sheet1

'Sprungmarke, falls das Datum fehlt oder falsch eingegeben wurde
Zurück_Datumeingabe_falsch:

UserForm1.TextBox1 = DateSerial(Year(Date), Month(Date) - 1, 1) 'ermitttelt ersten Tag vom Vormonat
UserForm1.TextBox2 = DateSerial(Year(Date), Month(Date), 1 - 1) 'ermittelt letzten Tag vom vormonat
UserForm1.Show                             'Zeige die UserForm1 an

' Prüfung, ob in UserForm das Datum "Lieferzeitraum von" und Lieferzeitraum bis" eingegeben sind
If UserForm1.TextBox1 = "" Or UserForm1.TextBox2 = "" Then
    MsgBox "Bitte Datum eingeben", vbInformation, "fehlendes Datum"
    GoTo Zurück_Datumeingabe_falsch
End If

' Prüfung, ob in UserForm das Datum "Lieferzeitraum von" und Lieferzeitraum bis" im korrekten Format ist.
If Not IsDate(UserForm1.TextBox1) Or Not IsDate(UserForm1.TextBox2) Then
    MsgBox "Datum hat falsches Format", vbInformation, "Bitte Datum prüfen"
GoTo Zurück_Datumeingabe_falsch

Else

DateFrom = UserForm1.TextBox1.Value
DateTo = UserForm1.TextBox2.Value

sPfad = "\\whh.loc\orga\"
sPfad1 = "C:\Users\Public\Documents\"
sDatei = "Template_Fakturierungsbelege.xlsm"

If Dir(sPfad & sDatei) <> "" Then
       'Workbooks.Open (sPfad & sDatei)
       Set WbDatei2 = Workbooks.Open(sPfad & sDatei)
       'ThisWorkbook.Activate
       'Application.ActiveWindow.Visible = False
     Else
        MsgBox "Den angegebenen Ordner """ & sPfad & """" & Chr(10) & _
        "und/oder die gesuchte Datei """ & sDatei & """ gibt es nicht!", _
        16, "   Hinweis für " & Application.UserName
       Exit Sub
End If

Application.ScreenUpdating = False

MonthLieferung = Format(DateTo, "mmmm")
sLieferzeitraum = Format(DateFrom, "dd.mm.yyyy") & " " & "bis" & " " & Format(DateTo, "dd.mm.yyyy")

strDateiname = Range("A1").Value & "_" & sLieferzeitraum   ' Dateiname = Text aus Zelle A1 + Lieferzeitraum mit Datum von bis

Unload UserForm1

    'letzte Zeile vom JReport ermitteln
    WbDatei1.Activate
    lngLZeile1 = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
             
WbDatei2.Sheets("Sheet2").Cells(3, 3).Value = sLieferzeitraum
WbDatei2.Sheets("Sheet2").Cells(4, 3).Value = Application.UserName        ' Daten aufbereitet von
WbDatei2.Sheets("Sheet2").Cells(4, 7).Value = FileDateTime(ThisWorkbook.FullName)       ' Zeitstempel
             
' ** ABFRAGE DER KUNDEN
' ** Kunde A: Schweiz

    A = 25                             ' Im Fakturierungsbeleg ab Zeile 25 die Werte reinschreiben
    For i = 1 To lngLZeile1    ' lngLZeile1 ist die letzte Zeile vom JReport wo ein Eintrag ist

    If WbDatei1.Sheets(1).Cells(i, 1) Like "Kunde_A_Schweiz*" Then
       
        ' Datumsprüfung "Lieferzeitraum von"
        If WbDatei1.Sheets("Sheet1").Cells(i, 4).Value <= DateFrom Then
            WbDatei2.Sheets("Sheet2").Cells(A, 4).Value = DateFrom
        Else
            WbDatei2.Sheets("Sheet2").Cells(A, 4).Value = WbDatei1.Sheets("Sheet1").Cells(i, 4).Value
        End If
       
        ' Datumsprüfung "Lieferzeitraum bis"
        If WbDatei1.Sheets("Sheet1").Cells(i, 5).Value >= DateTo Then
            WbDatei2.Sheets("Sheet2").Cells(A, 5).Value = DateTo
        Else
            WbDatei2.Sheets("Sheet2").Cells(A, 5).Value = WbDatei1.Sheets("Sheet1").Cells(i, 5).Value
        End If
        ' Abgabe Menge

        WbDatei2.Sheets("Sheet2").Cells(A, 3).Value = WbDatei1.Sheets("Sheet1").Cells(i, 10).Value
        ' Betrag
        WbDatei2.Sheets("Sheet2").Cells(A, 8).Value = WbDatei1.Sheets("Sheet1").Cells(i, 11).Value
        ' Liefermonat:
        'WbDatei2.Sheets("Sheet2").Range("A25").Value = MonthLieferung
        A = A + 1
    End If
    Next i
  
' ** Partner Kunde A: Deutschland

    A = 65                     ' Im Fakturierungsbeleg ab Zeile 65 die Werte reinschreiben
    For i = 1 To lngLZeile1    ' lngLZeile1 ist die letzte Zeile vom JReport wo ein Eintrag ist
    If WbDatei1.Sheets(1).Cells(i, 1) Like "Kunde_A_Deutschland*" Then
        ' Datumsprüfung "Lieferzeitraum von"
        If WbDatei1.Sheets("Sheet1").Cells(i, 4).Value <= DateFrom Then
            WbDatei2.Sheets("Sheet2").Cells(A, 4).Value = DateFrom
        Else
            WbDatei2.Sheets("Sheet2").Cells(A, 4).Value = WbDatei1.Sheets("Sheet1").Cells(i, 4).Value
        End If
        ' Datumsprüfung "Lieferzeitraum bis"
        If WbDatei1.Sheets("Sheet1").Cells(i, 5).Value >= DateTo Then
            WbDatei2.Sheets("Sheet2").Cells(A, 5).Value = DateTo
        Else
            WbDatei2.Sheets("Sheet2").Cells(A, 5).Value = WbDatei1.Sheets("Sheet1").Cells(i, 5).Value
        End If
        ' Abgabe Menge
        WbDatei2.Sheets("Sheet2").Cells(A, 3).Value = WbDatei1.Sheets("Sheet1").Cells(i, 10).Value
        ' Betrag
        WbDatei2.Sheets("Sheet2").Cells(A, 8).Value = WbDatei1.Sheets("Sheet1").Cells(i, 11).Value    
        ' Liefermonat:
        'WbDatei2.Sheets("Sheet2").Range("A65").Value = MonthLieferung
        A = A + 1
    End If
    Next i
              
 ' ** Partner Kunde B: Schweiz
    A = 105                           ' Im Fakturierungsbeleg ab Zeile 105 die Werte reinschreiben

  '.....gleicher Aufbau wie bei Kunde

Es sind insgesamt über 50 Kunden mit unterschiedlichen Ländern (Schweiz, Deutschland und allenfalls auch Frankreich) abzufragen.

Ich bedanke mich für eure Hilfe. Gruss, Andreas

Answer 1

Hallo Andreas :-)

Die Codegröße ist limitiert(Kb)!

Den Fehler machen viele Anfänger (geteiltes Leid ist halbes Leid (kicer kicher))!

Beschäftige dich mal mit Funktions aufrufe wie Modul aufrufe!

Ich liebe zwar auch Spaghetticode,das heißt aber nicht,das du das auch so machen sollst.

Unterteile dein Modul in kleine Module oder/und Funktionen und rufe sie mit Call bzw Funktionsname auf.

Gegebenenfalls mit übergabe von Variablen(Funktionen wie auch Module)!

Nach der Unterteilung,hast du nun den besseren Überblick und kannst dich nach Monaten oder Jahren wieder schnell orientieren ohne dich groß wieder einzuarbeiten :-)

Gruß Nighty

Answer 2

Hallo Andreas,

du kannst auch versuchen, statt 50 mal den Code für die einzelnen Kunden zu schreiben, das über eine Schleife zu machen:

Sub Fakturierungsbeleg()

Dim sPfad, sPfad1 As String       ' der Ordner-Pfad der Excel-Mappen
Dim sDatei, sDatei1 As String     ' die zu beschreibende Datei und zu speichernde Datei
Dim WbDatei1 As Workbook       ' Quelle
Dim WbDatei2 As Workbook       ' Ziel
Dim lngLZeile1, lngLZeile2 As Long
Dim DateFrom As Date                ' Lieferdatum von
Dim DateTo As Date                    ' Lieferdatum bis
Dim MonthLieferung As String     ' Monatsname vom Lieferdatum
Dim sLieferzeitraum As String
Dim strDateiname As String
Dim lngKunde As Long
Dim strKunde As String

Set WbDatei1 = ActiveWorkbook   'Quelle Sheet1

'Sprungmarke, falls das Datum fehlt oder falsch eingegeben wurde
Zurück_Datumeingabe_falsch:

UserForm1.TextBox1 = DateSerial(Year(Date), Month(Date) - 1, 1) 'ermitttelt ersten Tag vom Vormonat
UserForm1.TextBox2 = DateSerial(Year(Date), Month(Date), 1 - 1) 'ermittelt letzten Tag vom vormonat
UserForm1.Show                             'Zeige die UserForm1 an

' Prüfung, ob in UserForm das Datum "Lieferzeitraum von" und Lieferzeitraum bis" eingegeben sind
If UserForm1.TextBox1 = "" Or UserForm1.TextBox2 = "" Then
    MsgBox "Bitte Datum eingeben", vbInformation, "fehlendes Datum"
    GoTo Zurück_Datumeingabe_falsch
End If

' Prüfung, ob in UserForm das Datum "Lieferzeitraum von" und Lieferzeitraum bis" im korrekten Format ist.
If Not IsDate(UserForm1.TextBox1) Or Not IsDate(UserForm1.TextBox2) Then
    MsgBox "Datum hat falsches Format", vbInformation, "Bitte Datum prüfen"
GoTo Zurück_Datumeingabe_falsch

Else

DateFrom = UserForm1.TextBox1.Value
DateTo = UserForm1.TextBox2.Value

sPfad = "\\whh.loc\orga\"
sPfad1 = "C:\Users\Public\Documents\"
sDatei = "Template_Fakturierungsbelege.xlsm"

If Dir(sPfad & sDatei) <> "" Then
       'Workbooks.Open (sPfad & sDatei)
       Set WbDatei2 = Workbooks.Open(sPfad & sDatei)
       'ThisWorkbook.Activate
       'Application.ActiveWindow.Visible = False
     Else
        MsgBox "Den angegebenen Ordner """ & sPfad & """" & Chr(10) & _
        "und/oder die gesuchte Datei """ & sDatei & """ gibt es nicht!", _
        16, "   Hinweis für " & Application.UserName
       Exit Sub
End If

Application.ScreenUpdating = False

MonthLieferung = Format(DateTo, "mmmm")
sLieferzeitraum = Format(DateFrom, "dd.mm.yyyy") & " " & "bis" & " " & Format(DateTo, "dd.mm.yyyy")

strDateiname = Range("A1").Value & "_" & sLieferzeitraum   ' Dateiname = Text aus Zelle A1 + Lieferzeitraum mit Datum von bis

Unload UserForm1

    'letzte Zeile vom JReport ermitteln
    WbDatei1.Activate
    lngLZeile1 = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
             
WbDatei2.Sheets("Sheet2").Cells(3, 3).Value = sLieferzeitraum
WbDatei2.Sheets("Sheet2").Cells(4, 3).Value = Application.UserName        ' Daten aufbereitet von
WbDatei2.Sheets("Sheet2").Cells(4, 7).Value = FileDateTime(ThisWorkbook.FullName)       ' Zeitstempel
             
'Abfrage der Kunden

For lngKunde = 1 To 2
  'Daten für Kunden
  Select Case lngKunde
    Case 1
       A = 25
       strKunde = "Kunde_A_Schweiz*"
    Case 2
       A = 65
       strKunde = "Kunde_A_Deutschland*"
   End Select
       
       
  ' Liefermonat:(soll doch wahrscheinlich nur einmal ins Sheet geschrieben werden)
  WbDatei2.Sheets("Sheet2").Cells(1, A).Value = MonthLieferung
       
       
' ** ABFRAGE DER KUNDEN
    For i = 1 To lngLZeile1    ' lngLZeile1 ist die letzte Zeile vom JReport wo ein Eintrag ist

      If WbDatei1.Sheets(1).Cells(i, 1) Like strKunde Then
       
        ' Datumsprüfung "Lieferzeitraum von"
        If WbDatei1.Sheets("Sheet1").Cells(i, 4).Value <= DateFrom Then
            WbDatei2.Sheets("Sheet2").Cells(A, 4).Value = DateFrom
        Else
            WbDatei2.Sheets("Sheet2").Cells(A, 4).Value = WbDatei1.Sheets("Sheet1").Cells(i, 4).Value
        End If
       
        ' Datumsprüfung "Lieferzeitraum bis"
        If WbDatei1.Sheets("Sheet1").Cells(i, 5).Value >= DateTo Then
            WbDatei2.Sheets("Sheet2").Cells(A, 5).Value = DateTo
        Else
            WbDatei2.Sheets("Sheet2").Cells(A, 5).Value = WbDatei1.Sheets("Sheet1").Cells(i, 5).Value
        End If
        ' Abgabe Menge

        WbDatei2.Sheets("Sheet2").Cells(A, 3).Value = WbDatei1.Sheets("Sheet1").Cells(i, 10).Value
        ' Betrag
        WbDatei2.Sheets("Sheet2").Cells(A, 8).Value = WbDatei1.Sheets("Sheet1").Cells(i, 11).Value
        A = A + 1
      End If
    Next i
 Next lngKunde

End Sub

Natürlich musst du ggf. noch etwas basteln und Anpassungen vornehmen.

Gruß

M.O.

Answer 3

Hallo M.O. und Nighty,

ich habe den Code von M.O. bereits ausgetestet und ohne grosse Anpassungen läuft alles perfekt durch.

Habe noch nicht sämtliche Kunden implementiert, jedoch bin ich guten Mutes.

Herzlichen Dank für eure rasche Hilfe...einfach super.

Gruss

Andreas