AW: Makro: Neues Blatt plus Inhalt Einfuegen
21.12.2012 15:29:58
Marius
Also ich habe es soweit editiert, wie ich konnte. Natuerlich klappen meine Scripte nicht.
Code: ButtonZaehlen
Bei dem Script ButtonsZaehlen wirft der mir 0 aus. Kann ich dieses "iCnt" nicht direkt in "ButtonAdder" einfuegen?
Sub ButtonsZaehlen()
'Variablendeklarationen
'Shape
Dim butShape As Shape
'Integer
Dim iCnt%
'Schleife ueber alle Shapes
For Each butShape In ActiveSheet.Shapes
'Wenn der Shapename mit G beginnt, dann zaehler hochsetzen
If butShape.Name Like "G3323#" Then iCnt = iCnt + 1
'naechste Schleife ueber alle Shapes
Next
'Meldung ausgeben
MsgBox iCnt
End Sub
Code: ButtonAdder
Den Button einmalig zu positionieren habe ich hinbekommen (fettdruck). Nur fehlt mir die variable Shapebezeichnung. Koennte man dort vielleicht "ButtonNr" eingeben? Deine Funktion fuer die Reihenbestimmung klappt auch super. Ich bekomme aber keine mathematische Loesung fuer die Spaltenbestimmung (fettdruck) hin.
Wenn ich den Button mit einem Zusatzzeichen versehen muss, also "G3323#" anstelle von "G3223" muss ich "ButtonName" weglassen, oder? Ansonsten wuerde er mir "G3323# Heinz" in den Button schreiben, was mir bei Application.Caller wieder Probleme bereiten wuerde, oder?
Die Spalte muss entweder 2,5 oder 8 ergeben. Das ist echt kompliziert. Waere es einfacher, nur zwei Spalten zu machen. Ungerade Buttonanzahl = Spalte 2, gerade Buttonanzahl = Spalte 5?
Sub ButtonAdder()
' ButtonAdder Makro
Dim ButtonNr As String
Dim ButtonName As String
ButtonNr = InputBox("Please enter Button Number", "Button Number", "e.g. G3115#, M0160#")
'wenn nicht abgebrochen wurde, dann
If StrPtr(ButtonNr) 0 Then
'wenn mehr als 0 Zeichen eingegeben wurden, dann
If Len(ButtonNr) > 0 Then
'Fehlerbehandlung wenn Blattname schon vorhanden
On Error Resume Next
'Fehlerbehandlung ruecksetzen
On Error GoTo 0
'wenn umbenennen Fehler ergibt, dann
If Err Then
'Meldung ausgeben
MsgBox "Number already exists. Please try again!"
'Fehler zuruecksetzen
Err.Clear
'Eingebe zuruecksetzen
ButtonNr = ""
'Ende wenn umbenennen Fehler ergibt, dann
End If
'Ende wenn mehr als 0 Zeichen eingegeben wurden, dann
End If
'oder wenn abgebrochen wurde, dann
Else
'Meldung ausgeben
MsgBox "New Button without Number. Please delete this Button"
'Makro verlassen
Exit Sub
'Ende wenn nicht abgebrochen wurde, dann
End If
ButtonName = InputBox("Please enter Button Name", "Button Name", "e.g. Heinz")
'wenn nicht abgebrochen wurde, dann
If StrPtr(ButtonName) 0 Then
'wenn mehr als 0 Zeichen eingegeben wurden, dann
If Len(ButtonName) > 0 Then
'Fehlerbehandlung wenn Blattname schon vorhanden
On Error Resume Next
'Fehlerbehandlung ruecksetzen
On Error GoTo 0
'wenn umbenennen Fehler ergibt, dann
If Err Then
'Meldung ausgeben
MsgBox "Name already exists. Please try again!"
'Fehler zuruecksetzen
Err.Clear
'Eingebe zuruecksetzen
ButtonName = ""
'Ende wenn umbenennen Fehler ergibt, dann
End If
'Ende wenn mehr als 0 Zeichen eingegeben wurden, dann
End If
'oder wenn abgebrochen wurde, dann
Else
'Meldung ausgeben
MsgBox "New Button without Name. Please delete this Button"
'Makro verlassen
Exit Sub
'Ende wenn nicht abgebrochen wurde, dann
End If
ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 63.75, 237.75, 115.5, _
41.25).Select
Selection.ShapeRange.ShapeStyle = msoShapeStylePreset25
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = ButtonNr
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 6). _
ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignCenter
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 6).Font
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorDark1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Size = 11
.Name = "+mn-lt"
End With
ActiveSheet.Shapes("Rounded Rectangle 4").Left = ActiveSheet.Cells(2,Formel fuer _
Spaltenbestimmung).Left
ActiveSheet.Shapes("Rounded Rectangle 4").Top = ActiveSheet.Cells(4 + _
WorksheetFunction.RoundUp(7 / 3, 0) * 4, 2).Top
Selection.OnAction = "AlleFormularButtonsG"
Range("D21").Select
End Sub
Code: AlleFormularButtonsG
Bei AlleFormularButtonsG wirft mir der Application.Caller leider nicht einen Button Namen wie "G3323" aus. Ich gebe "G3323#" als Buttonnamen an, aber Application.Caller sagt mir "Rounded Rectangle 4", den Namen der Buttonform.
Sub AlleFormularButtonsG()
Sheets(Left(Application.Caller, Len(Application.Caller) - 1)).Select
Range("B65536").End(xlUp).End(xlUp).Select
Cells(ActiveCell.Row + 1, ActiveCell.Column).Select
End Sub
Ich habe die Datei noch einmal hochgeladen, vielleicht ist das einfacher.
Vielen Dank schonmal fuer deine unermuedliche Hilfe.
https://www.herber.de/bbs/user/83111.xlsm