noch eleganter
22.03.2022 15:41:35
UweD
geht es so
lösche das Makro im Codebereich der Tabelle und füge das hier im Codebereich von "DieseArbeitsmappe" ein
Dann hast du das Makro nur an einer Stelle uns es wird nicht immer mitkopiert
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error GoTo Fehler
Dim Tb1 As Worksheet, TbM As Worksheet
Dim LrM As Integer, Z1 As Integer, ZM As Integer
Dim Anz As Integer, Z1x As Integer, Zus As Integer
Const APPNAME = "Worksheet_Change"
Set Tb1 = ActiveSheet
Set TbM = Sheets("Massen")
Z1 = 13 ' erste Zielzeile
ZM = 6 ' Ab Zeile..
Select Case Tb1.Name
Case "Preisliste", "Übersicht", TbM.Name
'mach nix
Case Else
If Not Intersect(Tb1.Range("D8"), Target) Is Nothing Then
Z1x = Tb1.Cells(Tb1.Rows.Count, "K").End(xlUp).Row 'Zeile mit der Summe
Anz = WorksheetFunction.CountIf(TbM.Columns(1), Target) ' Anzahl gefunden
If Anz > 0 Then
If Anz > Z1x - Z1 Then
Zus = Anz - Z1x + Z1 'Zusätzlich benötigte Zeilen
Application.EnableEvents = False
Tb1.Rows(Z1).Copy
Tb1.Rows(Z1 + 1).Resize(Zus).Insert Shift:=xlDown 'oben einfügen
Tb1.Rows(Z1x + 1 + Zus).Resize(Zus).Delete Shift:=xlUp 'unten löschen
Application.CutCopyMode = False
Application.EnableEvents = True
End If
'Reset Zielbereich
Application.EnableEvents = False
Tb1.Cells(Z1, 1).Resize(Z1x - Z1 + Zus, 11).ClearContents
Application.EnableEvents = True
With TbM
LrM = .Cells(.Rows.Count, "A").End(xlUp).Row 'Letzet Zeile in A
If .FilterMode Then .ShowAllData ' Autofilter alle
.ListObjects("tb_Massen").Range.AutoFilter Field:=1, Criteria1:=Target.Text
Application.EnableEvents = False
'C:D nach A:B
.Cells(ZM, 3).Resize(LrM - ZM + 1, 2).Copy
Tb1.Cells(Z1, 1).Resize(Anz, 2).PasteSpecial Paste:=xlPasteValues
'Ab E
.Cells(ZM, 5).Resize(LrM - ZM + 1, 7).Copy
Tb1.Cells(Z1, 5).Resize(Anz, 1).PasteSpecial Paste:=xlPasteValues
.ShowAllData ' Autofilter alle
Application.EnableEvents = True
End With
Else
MsgBox "Keine Daten für '" & Target.Text & "' gefunden"
End If
End If
End Select
'*** Fehlerbehandlung
Err.Clear
Fehler:
Application.EnableEvents = True
If Err.Number 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _
& "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub
LG UweD