Thema: Eintrag von Werten in verschiedene Arbeitsmappen

ClassModule: DieseArbeitsmappe

Private Sub Workbook_BeforeClose(Cancel As Boolean)
   Dim wks As Worksheet
   Dim iRow As Integer, iRowL As Integer, iRowT As Integer
   Dim sPath As String, sNo As String, sFile As String, sNoOld As String
   sPath = Application.DefaultFilePath & "\"
   If MsgBox("Verteilung vornehmen?", vbQuestion + vbYesNo) = vbNo Then Exit Sub
   Application.ScreenUpdating = False
   Worksheets("Tabelle1").Select
   Set wks = ActiveSheet
   Range("A1").CurrentRegion.Sort key1:=Range("G2"), order1:=xlAscending, header:=xlYes
   iRowL = wks.Cells(Rows.Count, 1).End(xlUp).Row
   For iRow = 2 To iRowL
      sNoOld = sNo
      Select Case wks.Cells(iRow, 7).Value
         Case Is <= 2500
            sNo = "1"
         Case Is <= 5000
            sNo = "2"
         Case Is <= 7500
            sNo = "3"
         Case Else
            sNo = "4"
      End Select
      If wks.Cells(iRow, 7).Value <> Cells(iRow - 1, 7).Value Then
         sFile = "Pruefen_" & sNo & ".xls"
         If Dir(sPath & sFile) <> "" Then
            Workbooks.Open sPath & sFile
         Else
            Workbooks.Add 1
            wks.Range("A1:H1").Copy Range("A1")
         End If
      End If
      Do While Int(wks.Cells(iRow, 7).Value / 2500) = Int(wks.Cells(iRow + 1, 7).Value / 2500) Or iRow = iRowL
         iRowT = Cells(Rows.Count, 1).End(xlUp).Row + 1
         Range(Cells(iRowT, 1), Cells(iRowT, 8)).Value = wks.Range(wks.Cells(iRow, 1), wks.Cells(iRow, 8)).Value
         iRow = iRow + 1
         If iRow > iRowL Then Exit Do
      Loop
      ActiveWorkbook.SaveAs sPath & sFile
      ActiveWorkbook.Close savechanges:=False
   Next iRow
   Application.ScreenUpdating = True
End Sub

Beiträge aus dem Excel-Forum zu den Themen Ereignis und BeforeClose