Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Funktionsteil extrahieren

Betrifft: Funktionsteil extrahieren von: Marcus Kempf
Geschrieben am: 10.11.2014 13:17:06

Hallo,

der nette Tino, den ich hier leider seit einiger Zeit nicht mehr habe schreiben sehen hat mir mal folgendes nettes Konstrukt gebaut.

Option Explicit

Sub Start_Format()
Dim i&, n&, nn&
Dim sMonat1$, sMonat2$
Dim Row1&, Row2&, nCounterBereich&
Dim rngDataBereich As Range, ArData, ArBT(), rngBT As Range, ArMA
Dim Farbe1, Farbe2
Dim booFund As Boolean
Dim MaxRow&

Farbe1 = RGB(0, 200, 0) 'Farbe 1
Farbe2 = RGB(125, 155, 255) 'Farbe 2

Call Events_(False)

'Datenbereich
With Tabelle1
    MaxRow = ExecuteExcel4Macro("LOOKUP(2,1/('" & .Name & "'!R1C2:R1000C2<>""""),ROW('" & .Name  _
 _
& "'!R1C2:R1000C2))")
    On Error Resume Next
    .Rows("43:" & MaxRow).Ungroup
    On Error GoTo 0: Err.Clear: Err.Number = 0
    On Error GoTo ErrorHandler:

    Set rngDataBereich = .Range("A1", .Cells(MaxRow, 1))
    
    With .Outline
        .AutomaticStyles = False
        .SummaryRow = xlAbove
        .SummaryColumn = xlRight
    End With
End With



'keine Daten
If rngDataBereich.Rows.Count = 1 Then Exit Sub
'Daten in Array (geht schneller)
ArData = rngDataBereich.Offset(, 1).Value
'Row2 vorbelegen
Row2 = 1
With rngDataBereich
    
    For i = 1 To UBound(ArData)
        If IsDate(ArData(i, 1)) And ArData(i, 1) > 0 And ArData(i, 1) < 10 ^ 6 Then
            Row1 = i
            'Name Monat
            sMonat1 = Format(ArData(i, 1), "mmmm")
            sMonat2 = sMonat1
            If Not booFund Then
                With .Cells(i, 1).Resize(.Rows.Count - i)
                    .EntireRow.Hidden = False
                    .MergeCells = False
                    .FormulaR1C1 = "=TEXT(RC2,""MMMM"")"
                    .Orientation = xlHorizontal
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .Interior.Color = xlNone
                    
                    Set rngBT = .Offset(, 4).Resize(, 73)
                    ArMA = .Cells(1, 1).Offset(-7, 4).Resize(, 73).Value2
                End With
                booFund = True
            End If
        End If

        
        If sMonat2 <> "" Then
            For Row2 = Row1 To UBound(ArData)
                If Format(ArData(Row2, 1), "mmmm") <> sMonat2 Then
                    Row2 = Row2 - 1
                    Exit For
                ElseIf UBound(ArData) = Row2 Then
                    Exit For
                End If
            Next Row2

            'Bereich mehr als 2 Zellen?
            If Row2 - Row1 > 0 Then
                Format_Bereich Range(.Cells(Row1 + 1, 1), .Cells(Row2, 1)), .Cells(Row1, 1). _
Value
                nCounterBereich = nCounterBereich + 1
                Range(.Cells(Row1, 1), .Cells(Row2, 1)).Interior.Color = IIf(nCounterBereich  _
Mod 2 = 0, Farbe1, Farbe2)
            End If
            'wieder auf nächsten Monat vorbelegen
            i = Row2
        End If
    Next i
    On Error Resume Next
    .Parent.Outline.ShowLevels RowLevels:=1
    On Error GoTo 0: Err.Number = 0
    
    Application.Calculation = xlCalculationAutomatic
    
    ArData = rngBT.Columns(1).Offset(, -2).Value2
    ReDim Preserve ArBT(1 To rngBT.Rows.Count, 1 To rngBT.Columns.Count)
    For n = 1 To UBound(ArData)
        If ArData(n, 1) = "BT" Then
            For nn = 1 To UBound(ArBT, 2)
                If ArMA(1, nn) <> "" Then ArBT(n, nn) = 1
            Next nn
        End If
    Next n
    rngBT.Value = ArBT
End With

ErrorHandler:
If Err.Number <> 0 Then
    MsgBox Err.Description, _
           vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
           "Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End If
Call Events_(True)
End Sub

Sub Format_Bereich(rngRange As Range, strInhalt$)
With rngRange
    .ClearContents
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Orientation = xlVertical
    .MergeCells = True
    .Rows.Group
    .Cells(1, 1).Value = strInhalt
End With
End Sub

Sub Events_(booSchalter As Boolean)
With Application
    .EnableEvents = booSchalter
    .ScreenUpdating = booSchalter
    .Calculation = IIf(booSchalter, xlCalculationAutomatic, xlCalculationManual)
End With
End Sub



Hieraus benötige ich den kursiven Teil als allein lauffähigen Programmteil, den ich in eine andere Sub einfügen möchte.

Nach ausgiebigem Probieren bin ich gescheitert und frage nun euch mal um rat wie das am günstigsten zu bewerkstelligen ist.

Danke im Voraus.

  

Betrifft: AW: Funktionsteil extrahieren von: fcs
Geschrieben am: 10.11.2014 15:35:05

Hallo Marcus,

im oberen Teil des Codes werden ja verschiedenen Informationen/Daten ermittelt/gesetzt.
letzte Zeile: MaxRow
Datenbereich: rngDataBereich
Daten-Array: ArData
Vergleichs-Array: ArMA
Ziel-Bereich: rngBT

Diese Variablen müssen mit Leben gefüllt werden, bevor man den kursiven Teil starten kann.

In deinem vorhanden Code kann man alles löschen, was sich um Formatierungen und Gruppierung von Daten dreht. Aber ob das dann dem nahekommt, was du möchtest: ????

Gruß
Franz

Sub Start_Format()
  Dim i&, n&, nn&
  Dim rngDataBereich As Range, ArData, ArBT(), rngBT As Range, ArMA
  Dim booFund As Boolean
  Dim MaxRow&
  
  
  Call Events_(False)
  
  'Datenbereich
  With Tabelle1
      MaxRow = ExecuteExcel4Macro("LOOKUP(2,1/('" & .Name & "'!R1C2:R1000C2<>""""),ROW('" _
          & .Name & "'!R1C2:R1000C2))")
      On Error GoTo ErrorHandler:
  
      Set rngDataBereich = .Range("A1", .Cells(MaxRow, 1))
      
  End With
  
  
  
  'keine Daten
  If rngDataBereich.Rows.Count = 1 Then Exit Sub
  'Daten in Array (geht schneller)
  ArData = rngDataBereich.Offset(, 1).Value
  
  With rngDataBereich
      
      For i = 1 To UBound(ArData)
          If IsDate(ArData(i, 1)) And ArData(i, 1) > 0 And ArData(i, 1) < 10 ^ 6 Then
              
              If Not booFund Then
                  With .Cells(i, 1).Resize(.Rows.Count - i)
                      
                      Set rngBT = .Offset(, 4).Resize(, 73)
                      ArMA = .Cells(1, 1).Offset(-7, 4).Resize(, 73).Value2
                  End With
                  booFund = True
                  Exit For
              End If
          End If
      Next i
      
      Application.Calculation = xlCalculationAutomatic
      
      ArData = rngBT.Columns(1).Offset(, -2).Value2
      ReDim Preserve ArBT(1 To rngBT.Rows.Count, 1 To rngBT.Columns.Count)
      For n = 1 To UBound(ArData)
          If ArData(n, 1) = "BT" Then
              For nn = 1 To UBound(ArBT, 2)
                  If ArMA(1, nn) <> "" Then ArBT(n, nn) = 1
              Next nn
          End If
      Next n
      rngBT.Value = ArBT
  End With
  
ErrorHandler:
  If Err.Number <> 0 Then
      MsgBox Err.Description, _
             vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
             "Error: " & Err.Number, Err.HelpFile, Err.HelpContext
  End If
  Call Events_(True)
End Sub

Sub Events_(booSchalter As Boolean)
  With Application
      .EnableEvents = booSchalter
      .ScreenUpdating = booSchalter
      .Calculation = IIf(booSchalter, xlCalculationAutomatic, xlCalculationManual)
  End With
End Sub




  

Betrifft: AW: Funktionsteil extrahieren von: Marcus Kempf
Geschrieben am: 12.11.2014 10:01:17

Also das extrahieren will mir einfach nicht so wirklich gelingen.

Wenn ich das Snippet soweit reduziere, dass es noch funktioniert und nicht mehr formatierend wirkt, dann habe ich das Problem, dass mir alle bis dahin getätigten eingaben mit "" überschrieben werden.

Kann mir jemand erläutern, wodurch dies geschiet?


  

Betrifft: AW: Funktionsteil extrahieren von: fcs
Geschrieben am: 12.11.2014 12:50:38

Hallo Marcus,

wahrscheinlich passen die verschiedenen Offset-Werte, die beim Zuweisen von Zellbereichen zu Variablen oder Einlesen von Werten in Arrays verwendet werden, nicht zu den Daten, die du jetzt verarbeiten möchtest.

Ohne eine Beispieldatei mit vorher und nachher Tabellenblatt wird dir kaum jemand helfen können. Dafür ist das Makro zu komplex/unübersichtlich. Immerhin muss hier der Datenfluß von 2 Zellbereichen und 3 zum Teil mehrdimensionalen Datenarrays verfolgt werden.

Gruß
Franz


  

Betrifft: AW: Funktionsteil extrahieren von: Marcus Kempf
Geschrieben am: 12.11.2014 15:52:47

Ich habe die entsprechende Datei mal angehangen.

Ich möchte erreichen, dass beim Einfügen eines neuen Nutzers zur Gruppe an Brückentagen die 1 automatisch an den den entsprechenden Tagen gesetzt wird.

Dies sollte so wie ich es herauslese der kursive Teil übernehmen, ich bekomme ihn aber wie erwähnt nicht separat zum Laufen.

Zur generellen Funktionsweise:

wird das Jahr in Zelle A1 geändert, so werden die Zellen in Spalte A für die Monate getrennt, anhand des jeweiligen Datums neu mit dem korrekten Monat besetzt, wieder verbunden, gruppiert und eingefärbt.

An Feiertagen werden die entsprechenden Zeilen violet gefärbt, wenn in Zeile 37 der entsprechenden Spalte ein Wert vorhanden ist.
Identisch wird mit den Brückentagen (braun) verfahren.

https://www.herber.de/bbs/user/93717.xlsm


  

Betrifft: AW: Funktionsteil extrahieren von: Marcus Kempf
Geschrieben am: 12.11.2014 16:06:35

Ich habe das Ganze jetzt nochmal so hingebastelt, wie der Stand ist an dem ich scheitere.

Betätige ich nun den Button neuer Mitarbeiter, so wird die 1 am Brückentag korrekt gesetzt, jedoch verschwinden alle bisher getätigten Eingaben und ich werde einfach nicht schlau draus warum sie dies tun.

https://www.herber.de/bbs/user/93718.xlsm


  

Betrifft: AW: Funktionsteil extrahieren von: fcs
Geschrieben am: 14.11.2014 08:28:16

Hallo Marco,

ich hab mal versucht, das Makro nachzuvollziehen. Das Makro arbeitet für die Zuordnung der 1 für die "BT" alle Spalten der Tabelle "Normalschicht" ab und trägt bei Übereinstimming die 1 in das zu Beginn leere Daten-Array ArBT. Anschließend werden die Daten des Arrays in den Bereich rngBT geschrieben. Dadurch werden die vorhanden Daten überschrieben und es bleiben nur die 1-Werte übrig, alles andere ist weg.

Das Makro soll ja wohl nur dann ausgeführt werden, wenn ein neuer Mitarbeiter eingefügt wird und dann nur in dieser neuen Spalte die 1 eintragen?

Gruß
Franz


  

Betrifft: AW: Funktionsteil extrahieren von: Marcus Kempf
Geschrieben am: 14.11.2014 10:33:06

Hallo Franz,

genau so ist es gedacht.

Das Makro läuft ja auch bei Änderung des Jahres, hier ist das Löschen jedoch gewünscht, wird aber noch mit einer Abfrage versehen.


  

Betrifft: AW: Funktionsteil extrahieren von: fcs
Geschrieben am: 16.11.2014 19:28:29

Hallo Marco,

ich hab die Makros im Modul2 deiner Datei so angepasst, dass beim Einfügen eines neuen MA nur die Daten in der eingefügten Spalte angepasst werden.
Die Spalte O in der Datenbasis, die kopiert wird, muss nicht unbedingt gruppiert werden. Das Makro stellt die Gruppierungsebene der eingefügten Spalte jetzt auf Ebene der Spalte links von der Einfügespalte.

Gruß
Franz
https://www.herber.de/bbs/user/93803.xlsm


 

Beiträge aus den Excel-Beispielen zum Thema "Funktionsteil extrahieren"