VBA - zu komplex für genaue Beschreibung

[ralf_b]

Hallo Luisa,
 
hier mal ein Umsetzungsversuch.  Auch wenn du ihn eigentlich nicht verdient hast. Ohne Garantie.

Code:

Sub raumaufteilung()

    Dim rngHeader As Range, rfund  As Range
    Dim lrow   As Long, ofset  As Long
    Dim retVal
   
    Dim newWb  As Workbook, baseWb As Workbook
    Dim newName As String, shName As String, baseSh As Worksheet, roomSh As Worksheet
   
    Application.ScreenUpdating = False
    newName = Format(Now, "dd-mm-YYYY-hhmmss") & "_Raummappe.xlsx"
    Set baseWb = ThisWorkbook
    Set baseSh = baseWb.Worksheets("Maßnahmen")
    Set roomSh = baseWb.Worksheets("Raumbezeichnungen")
    Set newWb = Workbooks.Add(xlWBATWorksheet)
   
    With baseSh
        Set rngHeader = .Range("A2").Resize(, .Cells(2, .Columns.Count).End(xlToLeft).Column)
    End With
   
    newWb.SaveAs ThisWorkbook.Path & "\" & newName
    baseWb.Activate
    If baseSh.Range("A3") = "" Then
          baseSh.Range("A3") = "x"
          retVal = ""
    End If
   
    Do While roomSh.Cells(3 + ofset, 1) <> ""
        shName = roomSh.Cells(3 + ofset, 1)
        With newWb.Worksheets
        If Not wkShtExist(newWb.Name, shName) Then
            .Add(after:=.Item(.Count)).Name = shName
            rngHeader.Copy .Item(shName).Range("A1")
            lrow = 3
        Else
            lrow = .Item(shName).Cells(.Item(shName).Rows.Count, 1).End(xlUp).Row + 1
            If lrow < 3 Then lrow = 3
        End If
        End With
     
         
       If baseSh.AutoFilterMode Then baseSh.AutoFilter.ShowAllData
      
        baseSh.Range(baseSh.Range("A2"), baseSh.Cells.SpecialCells(xlCellTypeLastCell)).CurrentRegion.AutoFilter _
                                          Field:=1, Criteria1:=shName
       
        With baseSh.AutoFilter.Range
            .Offset(1).Resize(.Rows.Count - 1, rngHeader.Columns.Count).Copy _
                newWb.Worksheets(shName).Cells(lrow, 1)
        End With
       
        ofset = ofset + 1
    Loop
   
    baseSh.Range("A3") = retVal
    Application.DisplayAlerts = False
       newWb.Worksheets(1).Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub




Function wkShtExist(wb As String, sh As String) As Boolean

    Dim sht    As Worksheet
    For Each sht In Workbooks(wb).Worksheets
        If sht.Name = sh Then wkShtExist = True: Exit Function
    Next
    wkShtExist = False
End Function

[snb]

@ralph_b

Code:

Sub M_snb()
    With newWB
      y = Evaluate("isref('[" & .Name & "]" & shname & "'!A1)")
      If y = 0 Then .Sheets.Add(, .Sheets(.Sheets.Count)).Name = shname
    End With
End Sub

[ralf_b]

@snb

sieht nice aus, aber mein Code tuts auch.  Ich schätz er macht eh schon zu viel. Mal sehen wann das Gejammere losgeht.