AW: Nachfrage..
09.01.2018 14:25:55
UweD
Einige Fragen konnte ich aus deinem angefangenen Makro entnehmen
so?
Public TbI, TbM
Option Explicit
Sub Ellipse1_Klicken()
Dim ArrSpalte, ArrZeile, Sp, Ze, Anz As Integer, i
Dim UGr As String, NZ As Double
ArrSpalte = Array(4, 10, 16)
ArrZeile = Array(13, 38)
Set TbI = Sheets("Ishikawa-Diagramm")
Set TbM = Sheets("Maßnahmen")
Anz = 20 'Fixe Anzahl Ursachen
Application.ScreenUpdating = False
For Each Ze In ArrZeile 'für die Zeilen 13 und 38
For Each Sp In ArrSpalte 'für die Spalten 4, 10, 16
With TbI.Cells(Ze, Sp)
UGr = .Offset(-3, -3) 'Name Ursachengruppe
For i = 0 To Anz - 1
If .Offset(i, 0).Value > 4 Then
NZ = WorksheetFunction.Match(UGr, TbM.Columns(2), 0) 'Zeile Überschrift der Ursache
NZ = Evaluate("=MIN(IF(A" & NZ & ":A65536="""",ROW(" & NZ & ":65536)))") 'Erste Lücke in Spalte
'Zeile einfügen
TbM.Rows(NZ).Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove
Call Formatieren(NZ)
' Inhalte kopieren
TbM.Cells(NZ, 1).Resize(1, 2).Value = .Offset(i, -1).Resize(1, 2).Value
End If
Next i
End With
Next Sp
Next Ze
End Sub
Private Sub Formatieren(Zeile As Integer)
With TbM.Cells(Zeile, 1).Resize(1, 6)
With .Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
.RowHeight = 40
End With
End Sub
LG UweD