Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA: unterschiedliche Formeln eintragen

VBA: unterschiedliche Formeln eintragen
WalterK
Hallo,
mit folgendem Code werden nach der letzten belegten Spalte mittels Klick auf eine Schalftfläche Formeln eingefügt (bis zur letzten belegten Zeile). Funktioniert auch.
Jetzt geht es aber um 3 verschiedene Formeln die eingetragen werden sollen. Folgende Regeln sollen gelten:
1.) Die Formel kommt grundsätzlich in die Spalte nach dem Ende der Tabelle (im Beispiel in Spalte H)
2.) Beim 1. Klick auf die Schaltfläche soll die „Formel Nr. 1“ in Zelle H3 geschrieben und bis zur letzten belegten Zeile (im Beispiel H6) kopiert werden  das funktioniert bereits
3.) Beim 2. Klick auf die Schaltfläche soll die „Formel Nr. 2“ in Zelle H3 geschrieben und bis zur letzten belegten Zeile kopiert werden.
4.) Beim 3. Klick auf die Schaltfläche soll die „Formel Nr. 3“ in Zelle H3 geschrieben und bis zur letzten belegten Zeile kopiert werden.
5.) Beim 4. Klick auf die Schaltfläche sollen die Inhalte der Zellen von H3 bis zur letzten belegten Zeile (im Beispiel H6) gelöscht werden.
Hier noch mein Code:
Option Explicit
Sub Formeleintragen()
Dim lngA As Long
Dim LCol As Integer
Dim Plus As Integer
Application.ScreenUpdating = False 'Bildschirmaktualisierung ausschalten
LCol = Cells(2, Columns.Count).End(xlToLeft).Column 'Letzte Spalte ermitteln, in der in  _
Zeile 2 eine Überschrift steht
lngA = Cells.SpecialCells(xlCellTypeLastCell).Row 'letzte Zeilennummer in der Tabelle ü _
berhaupt
Plus = Cells(2, Columns.Count).End(xlToLeft).Column + 1 'Plus heißt, bis zur letzten  _
belegten Spalte und dann noch 1 Spalte dazu
With Range(Cells(3, Plus), Cells(lngA, Plus))
.FormulaLocal = "=Summe(A3:B3)" 'Formel Nr 1
'       =Summe(B3:F3) Formel Nr 2
'       =Summe(A3:G3) Formel Nr 3
End With
End Sub
Geht das überhaupt? Kann mir das jemand einbauen?
Hier noch die Tabelle: https://www.herber.de/bbs/user/72243.xls
Besten Dank und Servus, Walter

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: VBA: unterschiedliche Formeln eintragen
10.11.2010 21:47:32
Josef

Hallo Walter,
eine Möglichkeit.


Sub Formeleintragen()
  Dim lngA As Long
  Dim Plus As Integer
  Dim strFormula(3) As String, vntRet As Variant
  
  vntRet = Val(ActiveSheet.Shapes(Application.Caller).AlternativeText)
  
  vntRet = vntRet + 1
  
  If vntRet > 3 Then vntRet = 0
  
  ActiveSheet.Shapes(Application.Caller).AlternativeText = vntRet
  
  strFormula(0) = "=Summe(A3:B3)"
  strFormula(1) = "=Summe(B3:F3)"
  strFormula(2) = "=Summe(A3:G3)"
  strFormula(3) = ""
  
  lngA = Cells.SpecialCells(xlCellTypeLastCell).Row 'letzte Zeilennummer in der Tabelle überhaupt
  Plus = Cells(2, Columns.Count).End(xlToLeft).Column + 1 'Plus heißt, bis zur letzten belegten Spalte und dann noch 1 Spalte dazu
  
  Range(Cells(3, Plus), Cells(lngA, Plus)).FormulaLocal = strFormula(vntRet)
End Sub

Gruß Sepp

Anzeige
Ausgezeichnet! Danke Sepp. Servus, Walter
10.11.2010 21:59:00
WalterK
Jetzt gibt es doch noch ....
10.11.2010 22:11:06
WalterK
Hallo Sepp,
... ein Problem. Damit mir der Code für importierte Tabellen immer zur Verfügung steht habe ich ihn in ein Modul in die Personl.xls kopiert.
Allerdings bleibt er jetzt bei dieser Zeile mit dem Hinweis "Typen unverträglich" stehen:
vntRet = Val(ActiveSheet.Shapes(Application.Caller).AlternativeText)
Danke für die Hilfe, Servus Walter
AW: Jetzt gibt es doch noch ....
10.11.2010 22:16:23
Josef

Hallo Walter,
und wie löst du das Makro aus? In deinem ersten Beitrag hast du von einer Schaltfläche gesprochen und auch in deiner Beispieldatei hattest du diese Schaltfläche.

Gruß Sepp

Anzeige
AW: Jetzt gibt es doch noch ....
10.11.2010 22:22:09
WalterK
Hallo,
OK, in der Beispieldatei habe ich die Schaltfläche zu Testzwecken in der Tabelle stationiert.
Für mein Vorhaben wollte ich über Ansicht/Symbolleisten/Anpassen eine Schaltfläche anlegen und mit dem Modul in der Personl.xls verbinden. So jedenfalls habe ich es mit einem anderen Code auch gemacht.
Servus, Walter
AW: Jetzt gibt es doch noch ....
10.11.2010 22:30:31
Josef

Hallo Walter,
das sollte man aber dazu sagen, weil ich zum Beispiel im Alternativtext der Schatfläche den Zähler festgehalten habe.
Na ja, macht nichts, dann schreiben wir den Zähler eben in die Dolumenteigenschaften.

' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Sub Formeleintragen()
  Dim lngA As Long
  Dim Plus As Integer
  Dim strFormula(3) As String, intIndex As Integer
  
  intIndex = GetCustProp(ActiveWorkbook, "Formelzähler", 0)
  
  intIndex = intIndex + 1
  
  If intIndex > 3 Then intIndex = 0
  
  SetCustProp ActiveWorkbook, "Formelzähler", intIndex
  
  strFormula(0) = "=Summe(A3:B3)"
  strFormula(1) = "=Summe(B3:F3)"
  strFormula(2) = "=Summe(A3:G3)"
  strFormula(3) = ""
  
  With ActiveSheet
    lngA = .Cells.SpecialCells(xlCellTypeLastCell).Row 'letzte Zeilennummer in der Tabelle überhaupt
    Plus = .Cells(2, .Columns.Count).End(xlToLeft).Column + 1 'Plus heißt, bis zur letzten belegten Spalte und dann noch 1 Spalte dazu
    
    .Range(.Cells(3, Plus), .Cells(lngA, Plus)).FormulaLocal = strFormula(intIndex)
  End With
End Sub

Private Function GetCustProp(WBook As Workbook, propName As String, Optional propValue As Variant) As Variant
  ' Wert aus Dateieigenschaft auslesen. Wenn nicht vorhanden
  ' Anlegen und Optional mit Startwert belegen
  
  Dim propType As MsoDocProperties
  
  If Not IsMissing(propValue) Then
    Select Case VarType(propValue)
      Case vbString
        propType = msoPropertyTypeString
      Case vbBoolean
        propType = msoPropertyTypeBoolean
      Case vbByte, vbInteger, vbLong
        propType = msoPropertyTypeNumber
      Case vbSingle, vbDouble
        propType = msoPropertyTypeFloat
      Case vbDate
        propType = msoPropertyTypeDate
      Case Else
    End Select
  End If
  
  With WBook
    On Error GoTo NoName
    GetCustProp = .CustomDocumentProperties(propName).Value
    Exit Function
    NoName:
    If Err.Number = 5 Then
      Err.Clear
      .CustomDocumentProperties.Add _
        Name:=propName, _
        LinkToContent:=False, _
        Type:=propType, _
        Value:=propValue
      GetCustProp = propValue
    End If
  End With
End Function

Private Function SetCustProp(WBook As Workbook, propName As String, propValue As Variant)
  ' Wert in Dateieigenschaft schreiben. Wenn nicht vorhanden
  ' Anlegen und Wert eintragen
  
  Dim propType As MsoDocProperties
  
  Select Case VarType(propValue)
    Case vbString
      propType = msoPropertyTypeString
    Case vbBoolean
      propType = msoPropertyTypeBoolean
    Case vbByte, vbInteger, vbLong
      propType = msoPropertyTypeNumber
    Case vbSingle, vbDouble
      propType = msoPropertyTypeFloat
    Case vbDate
      propType = msoPropertyTypeDate
    Case Else
  End Select
  
  With WBook
    On Error GoTo NoName
    .CustomDocumentProperties(propName).Value = propValue
    Exit Function
    NoName:
    If Err.Number = 5 Then
      Err.Clear
      .CustomDocumentProperties.Add _
        Name:=propName, _
        LinkToContent:=False, _
        Type:=propType, _
        Value:=propValue
    End If
  End With
End Function

Gruß Sepp

Anzeige
Wow, das ist ja ein Service.
10.11.2010 22:41:56
WalterK
Hallo Sepp,
sorry für meine irreführenden Angaben.
Ein kleiner Schönheitsfehler ist noch vorhanden: Der Code beginnt immer mit der strFormula 1, dann 2, dann 3 und dann 0. Idealerweise sollte die Reihenfolge so wie im Code angeführt sein.
Ich bin Dir jedenfalls für die großartige Hilfe sehr dankbar.
Servus, Walter
AW: Wow, das ist ja ein Service.
10.11.2010 22:48:04
Josef

Hallo Walter,
ändere die Zeile
intIndex = GetCustProp(ActiveWorkbook, "Formelzähler", 0)

ab in
intIndex = GetCustProp(ActiveWorkbook, "Formelzähler", 3)


Gruß Sepp

Anzeige
Funktioniert einwandfrei, besten Dank Sepp!
10.11.2010 22:51:12
WalterK
Servus, Walter

306 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige