Excel VBA Makro - Dynamische Ausführung eines Makros

Pitfrog1212 · 18. April 2017

Hallo liebe Community,

bin relativ neu in VBA und habe folgendes Problem. Ich möchte eine Nutzwertanalyse mit Excel implementieren. Soweit so gut. Hat alles wunderbar funktioniert und es läuft auch. Nun möchte ich aber jene optimieren.

Auf einem Arbeitsblatt werden die Bewertungen des Teams in einer Matrix festgehalten. Jedes Teammitglied bewertet inwiefern ein Kriterium durch einen Lösungsansatz erfüllt wird. Danach wird der Mittelwert für den jeweiligen Ansatz gebildet und angezeigt. Nun ist es ja immer unterschiedlich wie viele Ansätze es für ein Problem gibt. Und genau da setzt mein Problem an.

IST-Situation: Im Moment gibt es maximal sieben Ansätze. Falls es mehr sind müsste der Betroffene händisch erweitern und die Formeln auch anpassen. Kein Hexenwerk, aber nervig. Falls es weniger Ansätze sind, sieht es nicht so "ordentlich" aus.

SOLL-Situation: Wo will ich hin? Ich möchte in der default-Situation, dass es nur eine Variante gibt. Über eine Tastenkombination möchte ich, dass neben der ersten Variante die nächste hinzugefügt wird. ABER: mit den korrekten Formeln und den richtigen Bezügen. Dies soll man ja nicht nochmal selbst anpassen müssen.

Über den Makro Recorder klappt das super, nur klappt das, wie auch erwartet, nur an der Stelle an der ich das Makro erstellt habe. Ich bekomme es auch hin, dass es dort eingefügt wird, wo eine Zelle ausgewählt ist, aber auch das finde ich umständlich. Es gibt bestimmt eine Lösung, dass so zu lösen. Ich weiß nur nicht wie, weil ich ein Newbie in VBA bin.

Zur Info, was der Code macht:

Sub Makro1()
'
' Makro1 Makro
'
' Tastenkombination: Strg+h
'
Range("AK2:AQ3").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
ActiveCell.FormulaR1C1 = _
"=IF(ISBLANK(Nutzwertanalyse!RC[-26]),"""", Nutzwertanalyse!RC[-26])"
Range("AK2:AQ3").Select
Range("AK3").Activate
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Selection.Font.Size = 12
Selection.Font.Bold = True
Selection.Font.Size = 14
Selection.Font.Size = 16
Range("AD4:AJ4").Select
Selection.Copy
Range("AK4").Select
ActiveSheet.Paste
Range("AK5:AQ16").Select
Application.CutCopyMode = False
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("AK18:AQ18").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
ActiveCell.FormulaR1C1 = _
"=IF(ISBLANK(R[-13]C),"""",AVERAGE(R[-13]C:R[-2]C[6]))"
Range("AK18:AQ18").Select
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Selection.Font.Size = 12
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
End Sub

Ich hoffe Ihr könnt mir weiterhelfen.

PS:

SO sieht das aus. Perfekt wäre es natürlich wenn ich noch zusätzlich die Anzahl der Beteiligten steuern könnte. Z.B. default Situation sind 3 Beteiligte und über anderen shortcut wird ein neuer hinzugefügt. Formel werden natürlich gleichzeitig angepasst.

Aber von mir aus auch erstmal die erste Baustelle angehen.

Beste Grüße

Pitfrog

Pitfrog1212

WOW

Danke das klappt "fast" perfekt.

Problem ist wenn ich das makro ausführe dann erscheint kein Name, da wo dann eigentlich Variante N stehen sollte.

Ausgangszelle ist C2, anstatt dann auf E2 zuzugreifen, nimmt sich das Makro F2 und das geht analog weiter so. Hab versucht das selber zu beheben. Dafür reichen allerdings meine VBA Kenntnisse nicht aus, da ich nicht ganz checke welcher Wert bei Vcount raus
kommen soll.

Weißt du eigentlich die ganzen Funktionen auswendig oder wie gehst du an so eine Aufgabe ran. Weißt du schon im voraus welche Variablen du definieren musst? Bin immer wieder erstaunt, wie man solche Codes programmiert.

Wie hast du VBA gelernt?

Andreas Killer

http://www.filehosting.at/file/details/658583/Nutzwertanalyse_Paarvergleich_DRAFT.xlsx

Das Ding funktioniert nicht, der Link öffnet ein Formular in dem man seine Mailadresse eingeben muss und meine akzeptiert er nicht. Das Ding ist eine Spamseite.

Ich arbeite seit langem damit:
https://www.dropbox.com

Andreas.

Andreas Killer

Warum wird das nichts? Kleinere Dinge habe ich schon per VBA/Makro gelöst bekommen.

Weil Du ein Konzept für komplexe Probleme brauchst, und was Du bisher beschrieben hast zeigt das Du keins hast.

Kleinere Dinge kann man sich zurechtbasteln, dagegen ist nichts einzuwenden. Da zeichnet man sich ein Makro auf, bastelt das zurecht und gut ist.

Leider zeigt meine Erfahrung aus über 20 Jahren Excel das diese Art Lösungen nur kurze Zeit funktionieren und meistens sehr fehleranfällig sind...

Lad doch mal Deine Datei auf einen Online File Hoster und poste den Download-Link hier. Dann kuck ich mal rein.

Andreas.

Andreas Killer

Option Explicit

Sub Variante_hinzu()

Dim VErste As Range, VLetzte As Range, VNächste As Range

Dim Vhinzu As Range, Vzellen As Range

Dim MyFormula As String

Dim Where As Range

Dim VCount As Integer

'Step 1: Variante kopieren

'Die erste Zelle der 1. Variante

Set VErste = Range("B2")

'Die erste Zelle der 2. Variante

Set VNächste = VErste.Offset(, 1)

'Die erste Zelle der letzten Variante

Set VLetzte = VErste.Cells(, Me.Columns.Count - VErste.Column).End(xlToLeft)

'Die erste Zelle der neuen Variante

Set Vhinzu = VLetzte.Offset(, 1)

Debug.Print "Positionen der Varianten", VErste.Address, VNächste.Address, VLetzte.Address, Vhinzu.Address

'Alle Zellen der 1. Variante holen

Set Vzellen = Intersect(VErste.CurrentRegion, VErste.MergeArea.EntireColumn)

Debug.Print "Zellen der 1. Variante", Vzellen.Address

'Kopieren

Vzellen.Copy

'Spaltenbreite zuerst

Vhinzu.PasteSpecial xlPasteColumnWidths

'Dann den Rest

Vhinzu.PasteSpecial

'Kopiermodus beenden

Application.CutCopyMode = False

'Step 2: Daten löschen

'Alle Zellen der neuen Variante

Set Vzellen = Intersect(VErste.CurrentRegion, Vhinzu.MergeArea.EntireColumn)

'Die ersten 3 Zeilen wollen wir nicht

Set Vzellen = Intersect(VErste.CurrentRegion, Vzellen.Offset(3))

'Inhalte entfernen

Vzellen.ClearContents

'Step 3: Formel erzeugen

'Basisformel "=WENN(ISTLEER(Nutzwertanalyse!C2);"";Nutzwertanalyse!C2)" mit Platzhaltern:

'Anmerkung:

' Jedes " innerhalb der Formel wird durch "" ersetzt

' Soll die Datei mit anderen Sprachen funktionieren, dann muss man englische Formeln verwenden

MyFormula = "=WENN(ISTLEER(@Where);"""";@Where)"

'Basiszelle

Set Where = Worksheets("Nutzwertanalyse").Range("C2")

'Anzahl Varianten

VCount = (Vhinzu.Column - VErste.Column) / VErste.MergeArea.Columns.Count

'Zelle weitersetzen

Set Where = Where.Offset(, VCount * 2)

'Formel erzeugen (in Englisch dann die ".Formula" Eigenschaft verwenden)

Vhinzu.FormulaLocal = Replace(MyFormula, "@Where", Where.Address(0, 0, External:=True))

End Sub

Andreas Killer

Es wär aber mal schön zu lernen wie es gehen könnte.
Die Anzahl der Beteiligten sollte aber kein Problem darstellen, oder? Was sich "nur" ändert ist die Range der Formel MITTELWERT, die muss erweitert werden um eine Spalte.

Zu Variante X auf dem Blatt "Variantenbewertung", theoretisch kann man die Funktion WENN(ISTLEER)... auch weglassen und einfach nur die Nummerierung erweitern. also wenn ich shortcut drücke erzeugt es variante 2 und wenn nochmal dann variante 3.

a) "gehen könnte"? D.h. das hier ist nur ein "Experiment"?

b) Ich sehe keine MITTELWERT Formel!?

Und "Formel anpassen" kannst Du vergessen, entweder macht Excel das automatisch oder Du erzeugst sie mit VBA neu.

c) Also "einfach nur" eine Variante hinzufügen... bedeutet n Spalten von a nach b kopieren und dann folgerichtig die Formeln erzeugen.

Dann nochmals: Mach die Augen zu, ich lösche jetzt x Beteiligte und y Varianten.

Das Makro muss nun erkennen:

1) Wo beginnt die erste Variante.

2) Wo endet die letzte Variante.

3) Wie viele Varianten schon da sind, bzw. wie viele Beteiligte eine Variante hat.

So in der Art?

Andreas.

Hi,

willkommen im Windows Forum!

Excel VBA Makro - Dynamische Ausführung eines Makros - Similar Threads - Excel VBA Makro	Forum	Datum
Excel VBA / Makro Zoomen Excel VBA / Makro Zoomen: Hallo Zusammen,1.Ich würde gerne per VBA / Makro Button alle Tabellenblätter per click z.B. auf 100% Zoomen Folgenden Code Habe ich benutzt. Leider wird nur das Tabellenblatt auf 100% gesetzt...	Microsoft Office	3. Oktober 2022
VBA Mittels Excel Makro andere Excel Datei Öffnen in welcher die Makros sofort Aktiviert sind VBA Mittels Excel Makro andere Excel Datei Öffnen in welcher die Makros sofort Aktiviert sind: Schönen Guten Tag, Ich habe eine Excel Datei, welche über ein Makro, eine Andere Excel Datei Nennen wir sie mal Excel Datei 2 öffnet. In der Excel Datei 2 wiederum sind wieder Makros enthalten,...	Microsoft Office	31. März 2022
VBA Excel dynamischen Array definieren VBA Excel dynamischen Array definieren: Guten Tag,ich habe derzeit Probleme ein zweidimensionales dynamisches Array zu redifinieren.Könnte mir bitte jemand einen funktionierenden Code zukommen lassen?Mit freundlichen GrüßenMSC	Microsoft Office	14. Dezember 2021
VBA Makro VBA Makro: Hallo da wir ja alle auf absehbare Zeit, etwas mehr Zeit haben werden, da ist es mein Wille mich in VBA Makro zu erlernen! Meine ersten Schrittein Excel sind grandios gescheitert! Hat jemand...	Microsoft Office	23. März 2020
[VBA] Ausführung einer Funktion/eines Makros unterbinden [VBA] Ausführung einer Funktion/eines Makros unterbinden: Hallo. Sitze gerade vor einem für mich nicht lösbaren Problem. Wenn man eine XLSM normal öffnet, wird im Kopf von Excel die Sicherheitswarnung eingeblendet. Der Code einer Funktion/eines...	Microsoft Office	11. Januar 2020
Excel VBA – Makro für ein Arbeitsblatt von zwei verschiedenen Arbeitsblättern aus ausführen Excel VBA – Makro für ein Arbeitsblatt von zwei verschiedenen Arbeitsblättern aus ausführen: Hallo Ich habe in der Tabelle 1 ein Makro, das eine Prozedur für Tabelle 1 ausführt. Nun möchte ich, dass ich das Makro für die Tabelle 1 ebenfalls, zusätzlich von der Tabelle 2 aus auslösen...	Microsoft Office	1. März 2019
VBA Makro VBA Makro: Guten Tag, ich habe folgrndes Makro geschrieben. Sub Hinweispfeil() ActiveSheet.Shapes.AddShape(msoShapeRightArrowCallout, 39, 18.75, 120.75, 61.5).Select Selection.ShapeRange.ShapeStyle =...	Microsoft Office	5. Januar 2018

Excel VBA Makro - Dynamische Ausführung eines Makros