|
Hallo Zusammen,
ich sitze hier vor einem Problem mit VBA in Excel (Office 2010).
Vielleicht kann mir jemand weiterhelfen.
Ich möchte mittels eines Makros eine Spalte einfügen (Makro wird mittels Schaltfläche ausgelöst).
Die Spalte wird kopiert (Spalte E) und rechts eingefügt. Jetzt habe ich in Spalte D ein Formel stehen
=SUMME(E10*$E$8)/($E$8)
Jetzt möchte ich die Formel wie Flogt erweitern:
=SUMME((E10*$E$8)+(F10*$F$8))/($E$8+$F$8)
Ich möchte mehrere Spalten einfügen können aber die Anzahl der Spalten ist immer unterschiedlich.
Anbei mein Code so weit habe ich es hinbekommen:
Sub Spaltenerweiterung()
Dim Nr As String
Dim Thema As String
Dim Datum As Date
Dim i As Integer
Dim j As Integer
Dim sArray() As String
Dim sFormel As String
Static iAddColumns As Integer 'zählt die eingefügten Spalten (für Mittelwertsformel)
Application.ScreenUpdating = False
'*********************************************************************************************
'Spalte E kopieren und nach Rechts einfŸgen anschlie§end Zelleninhalte E10 bis E44 l_schen
With Columns("E:E")
.Insert Shift:=xlToRight
.Copy
.Offset(0, -1).PasteSpecial (xlPasteAll)
End With
Range("E10:E44").ClearContents
Application.CutCopyMode = False
iAddColumns = iAddColumns + 1
'*********************************************************************************************
'Inputbox öffnen und Kopfdaten eingeben
'Thema = InputBox("Bitte Thema :")
'Range("E5") = Thema
'Datum = InputBox("Bitte Datum eingeben:")
'Range("E6") = Datum
'Nr = InputBox("Bitte Nr. eingeben:")
'Range("E9") = Nr
'**********************************************************************************************
'Mittelwertsformel erweitern
ReDim sArray(iAddColumns)
For i = 0 To iAddColumns
sArray(i) = "(" & Cells(10, i + 5).Address(0, 0) & "*" & Cells(8, i + 5).Address(1, 1) & ")" & "/" & "(" & Cells(8, i + 5).Address(1, 1) & ")"
sFormel = sFormel & sArray(i) & ", "
Next i
sFormel = "=Sum(" & sFormel
sFormel = Left(sFormel, Len(sFormel) - 2) & ")"
For j = 10 To 44
Range("D" & j).Formula = sFormel
Next j
'***************************************************************************************************************************
'Zeile MArkieren und nach unten ausfüllen
Range("D10").Select
Selection.AutoFill Destination:=Range("D10:D44"), Type:=xlFillDefault
Range("D10:D44").Select
Range("A3").Select
Application.ScreenUpdating = True
End Sub
Vielen Dank euch schon für eure Unterstützung!
Grüße
M_ephisto
|