Office Forum
www.Office-Loesung.de
Access :: Excel :: Outlook :: PowerPoint :: Word :: Office :: Wieder Online ---> provisorisches Office Forum <-
Zeilenumbruch mit angepasster Zeilenhöhe über Excel VBA
zurück: Problem mit Aufruf einer UserForm weiter: String Handling - Performance Optimierung Unbeantwortete Beiträge anzeigen
Neues Thema eröffnen   Neue Antwort erstellen     Status: Offen Facebook-Likes Diese Seite Freunden empfehlen
Zu Browser-Favoriten hinzufügen
Autor Nachricht
Bryan
Gast


Verfasst am:
02. Aug 2009, 21:56
Rufname:

Zeilenumbruch mit angepasster Zeilenhöhe über Excel VBA - Zeilenumbruch mit angepasster Zeilenhöhe über Excel VBA

Nach oben
       Version: Office 2007

Hi Leute,

habe hier eine Excel-Datei bekommen, die an einer Stelle angepasst werden müsste. Es wäre super, wenn ihr mir helfen könnten. Habe zwar schon in der Suchfunktion gesucht, aber zu diesem konkreten Thema finde ich nichts... und da ich ein absoluter Anfänger im Bereich VBA bin, kann ich mir das leider auch nicht zusammenreimen. Embarassed

Es geht darum, dass man eine Datenbasis hat und diese soll durch entsprechende Parametereingaben ins Makrotool als Output auf einem neuen Arbeitsblatt entsprechend sortiert werden. Das Problem bei der Ausgabe ist, dass die Zellen keinen Zeilenumbruch haben und der Text fortlaufend ist. D.h. alle Zellen (deren Anzahl je nach Parametereingabe variieren können) müssen einen Zeilenumbruch vorweisen und die Zeilenhöhe sollte entsprechend der Anzahl der Zeilen angepasst werden, so dass der Text auch sichtbar ist ohne die Zelle anzuklicken. Optimalerweise sollte diese Möglichkeit für jedes Arbeitsblatt, das durch eine neue Eingabe im Makrotool generiert werden kann bestehen.

Ich gebe mal der Praktikabilität halber den kompletten Sourcecode an... es wäre super super super, wenn ihr mir weiterhelfen könntet!!

Dank Euch!!

_____________________________________________________

'Version 1.0 vom 03.05.95


Option Explicit

Public Type abcTyp
'Stellt den erforderlichen Typ für die Funktionen l2Parameter, e1Parameter etc. bereit
'mit den Komponenten a, b und c wobei c optional ist
a As Double
u_b As Double
c As Double
End Type

Private dBlatt, QVBlatt As Object 'Zeiger auf dBank; QV
Private dBankDatenzeile, dBankSTRATASpalte, dBankGesellschaftsSpalte, dBankPositionsSpalte As Integer
Private QVGesellschaftsZeile, qvDatenZeile, qvStrataSpalte As Integer
Private dBankGröße As Integer 'Wieviele Einträge gibt es in dBank?
Private Funktionsstufe(11) As String 'Bezeichnung der Funktionsstufe
Private abPunkt(11) As Integer 'untere Grenze der Funktionsstufe
Private Stratamax, Stratamin As Integer
Private leer As Integer

Sub Präliminarien()
'Füllt die globalen Variablen mit den entsprechenden Werten
Dim n As Integer
Dim dlg As Object
Dim dummy As String

Application.ScreenUpdating = False

On Error Resume Next
Set QVBlatt = Sheets("QV")
On Error GoTo 0

'Starte Dialog (zuordnen)
Set dlg = DialogSheets("Parameter")

If dlg.Show Then 'OK wurde gewählt; Daten aus Dialogfeld müssen übernommen werden
dBankDatenzeile = CInt(dlg.EditBoxes("dBankDatenZeileFeld").Text)
dBankSTRATASpalte = SpaltenNr(dlg.EditBoxes("dBankSTRATASpalteFeld").Text)
dBankGesellschaftsSpalte = SpaltenNr(dlg.EditBoxes("dBankGesellschaftsSpalteFeld").Text)
dBankPositionsSpalte = SpaltenNr(dlg.EditBoxes("dBankPositionsSpalteFeld").Text)

QVGesellschaftsZeile = CInt(dlg.EditBoxes("QVGesellschaftsZeileFeld").Text)
qvDatenZeile = CInt(dlg.EditBoxes("QVDatenZeileFeld").Text)
qvStrataSpalte = SpaltenNr(dlg.EditBoxes("QVSTRATASpalteFeld").Text)

Set dBlatt = Sheets(dlg.EditBoxes("dBankName").Text)
If dlg.EditBoxes("Stratamax").Text <> "" Then Stratamax = CInt(dlg.EditBoxes("Stratamax").Text)
If Stratamax >= 90 Then Stratamax = 90
If dlg.EditBoxes("Stratamin").Text <> "" Then Stratamin = CInt(dlg.EditBoxes("Stratamin").Text)
If Stratamin <= 1 Then Stratamin = 1
If Stratamax <= Stratamin Then
Stratamax = 90
Stratamin = 1
End If

'Funktionsstufen übertragen
Funktionsstufe(1) = dlg.EditBoxes("f1").Text
Funktionsstufe(2) = dlg.EditBoxes("f2").Text
Funktionsstufe(3) = dlg.EditBoxes("f3").Text
Funktionsstufe(4) = dlg.EditBoxes("f4").Text
Funktionsstufe(5) = dlg.EditBoxes("f5").Text
Funktionsstufe(6) = dlg.EditBoxes("f6").Text
Funktionsstufe(7) = dlg.EditBoxes("f7").Text
Funktionsstufe(8) = dlg.EditBoxes("f8").Text
Funktionsstufe(9) = dlg.EditBoxes("f9").Text
Funktionsstufe(10) = dlg.EditBoxes("f10").Text
Funktionsstufe(11) = dlg.EditBoxes("f11").Text

For n = 1 To 11 'abPunkt(1-11) auf -1 initialisieren
abPunkt(n) = -1
Next n
On Error Resume Next 'Fehlererkennung aus; leere Einträge sollen nicht zum Absturz führen
abPunkt(1) = CInt(dlg.EditBoxes("p1").Text)
abPunkt(2) = CInt(dlg.EditBoxes("p2").Text)
abPunkt(3) = CInt(dlg.EditBoxes("p3").Text)
abPunkt(4) = CInt(dlg.EditBoxes("p4").Text)
abPunkt(5) = CInt(dlg.EditBoxes("p5").Text)
abPunkt(6) = CInt(dlg.EditBoxes("p6").Text)
abPunkt(7) = CInt(dlg.EditBoxes("p7").Text)
abPunkt(8) = CInt(dlg.EditBoxes("p8").Text)
abPunkt(9) = CInt(dlg.EditBoxes("p9").Text)
abPunkt(10) = CInt(dlg.EditBoxes("p10").Text)
abPunkt(11) = CInt(dlg.EditBoxes("p11").Text)
On Error GoTo 0 'Fehlererkennung wieder eingeschaltet
Else
End 'Abbruch wurde aufgerufen; daher Abbruch des Programmes
End If

'Anzahl der Einträge in dBank bestimmen
dBlatt.Select
n = dBankDatenzeile + 1
Do While Cells(n, dBankGesellschaftsSpalte).Value & Cells(n, dBankPositionsSpalte).Value <> ""
n = n + 1
Loop
dBankGröße = n - dBankDatenzeile

End Sub 'Präliminarien

Sub dummy()
'Leeres Unterprogramm zum Zuweisen z.B. für die Tasten des Dialogs
End Sub 'dummy

Function GesellschaftsSpalte(Gesellschaft As String) As Integer
'Wird aufgerufen mit dem Namen einer Gesellschaft und liefert die Spaltennr. in QV;
'Falls die Gesellschaft noch nicht existiert, wird 0 zurückgegeben
Dim n As Integer

For n = 2 To 52 '50 ist die maximale Zahl der Gesellschaften
If QVBlatt.Cells(QVGesellschaftsZeile, n).Value = Gesellschaft Then Exit For
Next n

If n < 52 Then
GesellschaftsSpalte = n
Else
GesellschaftsSpalte = 0
End If
End Function 'Gesellschaftsspalte

Function LeerePunktZeile(STRATA As Integer, GesellschaftsSpalte As Integer) As Integer
'Wird aufgerufen mit dem Punktwert der Position und der Spaltennr. der Gesellschaft
'Liefert die Nummer der ersten freien Zeile in QV
'Falls keine Zeile frei ist, wird 0 zurückgegeben
Dim n As Integer
n = qvDatenZeile - 1 'eins vor der größten Punktzahl
'Suche erstes Auftauchen der gesuchten Punktezahl
Do
n = n + 1
Loop While QVBlatt.Cells(n, qvStrataSpalte).Value > STRATA
'Suche erstes Auftauchen einer leeren Zelle
Do While QVBlatt.Cells(n, GesellschaftsSpalte) <> ""
n = n + 1
Loop
If QVBlatt.Cells(n, qvStrataSpalte).Value = STRATA Then
LeerePunktZeile = n
Else
LeerePunktZeile = 0
End If

End Function 'LeerePunktZeile

Sub QuervergleichErstellen()
Application.DisplayAlerts = False
'Erstellt automatisch den Quervergleich aus dBank im Blatt QV
'Benötigt wird ein leeres Blatt QVleer; das alte QV wird gelöscht
Dim n1, n2, n, SpaltenNr, ZeilenNr As Integer
Dim GesellschaftsName As String
Dim Gesellschaftszahl, STRATA As Integer
Dim letzteSTRATAZeile As String

' Anwendung.BildschirmAktualisierung = Falsch
Präliminarien

'Blatt QV vorbereiten
On Error GoTo QVNichtVorhanden:
Sheets("QV").Select
ActiveWindow.SelectedSheets.Delete
QVNichtVorhanden:
Sheets("Cross Comparison").Select
Sheets("Cross Comparison").Copy Sheets(1)
Sheets("Cross Comparison (2)").Name = "CC"
On Error GoTo 0
Set QVBlatt = Sheets("CC")

QVBlatt.Cells(QVGesellschaftsZeile, qvStrataSpalte + 1).Value = _
dBlatt.Cells(dBankDatenzeile, dBankGesellschaftsSpalte).Value
'erste Gesellschaft bereits eintragen

'Zeile für Zeile durchgehen und eintragen
For n = 1 To dBankGröße
STRATA = dBlatt.Cells(dBankDatenzeile - 1 + n, dBankSTRATASpalte)
If STRATA <= Stratamax And STRATA >= Stratamin Then
GesellschaftsName = dBlatt.Cells(dBankDatenzeile - 1 + n, dBankGesellschaftsSpalte)
If GesellschaftsName = "" Then GesellschaftsName = "?"
SpaltenNr = GesellschaftsSpalte(GesellschaftsName)
If SpaltenNr = 0 Then 'Gesellschaft ist in QV noch nicht vorhanden und muß eingefügt werden
Sheets("CC").Select
Columns(qvStrataSpalte + 1).Select
Selection.Insert Shift:=xlToRight
QVBlatt.Cells(QVGesellschaftsZeile, qvStrataSpalte + 1) = GesellschaftsName
SpaltenNr = qvStrataSpalte + 1
End If

ZeilenNr = LeerePunktZeile(STRATA, (SpaltenNr))
If (ZeilenNr = 0) Or (STRATA = 0) Then
ZeilenNr = qvDatenZeile
Do While QVBlatt.Cells(ZeilenNr, qvStrataSpalte) > STRATA
ZeilenNr = ZeilenNr + 1
Loop
If STRATA = 0 Then
Do While QVBlatt.Cells(ZeilenNr, qvStrataSpalte) <> "ENDE"
ZeilenNr = ZeilenNr + 1
Loop
ZeilenNr = ZeilenNr - 2
Else
Do While QVBlatt.Cells(ZeilenNr, qvStrataSpalte) = STRATA
ZeilenNr = ZeilenNr + 1
Loop
End If

'ZeilenNr steht genau hinter dem gesuchten Block
Sheets("CC").Select
Rows(ZeilenNr).Select
Selection.Insert Shift:=xlDown
'ZeilenNr steht auf eingefügter, leerer Zeile

QVBlatt.Cells(ZeilenNr, qvStrataSpalte).Value = STRATA
End If
QVBlatt.Cells(ZeilenNr, SpaltenNr).Value = dBlatt.Cells(n + dBankDatenzeile - 1, dBankPositionsSpalte).Value
End If
Next n
'Zahl der Gesellschaften ermitteln
Gesellschaftszahl = 1
Do While QVBlatt.Cells(QVGesellschaftsZeile, qvStrataSpalte + Gesellschaftszahl + 1) <> ""
Gesellschaftszahl = Gesellschaftszahl + 1
Loop

'Gesellschaftstitel löschen und neu einfügen (um Zentrierung zu erreichen)
QVBlatt.Cells(4, Gesellschaftszahl + 1).Value = ""
For n = 1 To Gesellschaftszahl
QVBlatt.Cells(4, n + 1).Value = "Function"
Next n


'QV formatieren: Format der in QVleer vorhandenen Spalte wird auf die vorigen Spalten kopiert
Columns(Gesellschaftszahl + qvStrataSpalte).Select
Selection.Copy
Columns(Chr(qvStrataSpalte + 65) & ":" & Chr(Gesellschaftszahl + qvStrataSpalte + 63)).Select
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

'Einfügen der Zeilenlinien: Zwischen zwei STRATA-Punkte werden Linien eingezogen
n1 = qvDatenZeile 'Oberster STRATA-Punktwert
Do While QVBlatt.Cells(n1, qvStrataSpalte).Value <> "ENDE" 'für jeden Punkteintrag
n2 = n1
Do While QVBlatt.Cells(n1, qvStrataSpalte) = QVBlatt.Cells(n2 + 1, qvStrataSpalte)
n2 = n2 + 1
Loop 'n2 wird auf den letzten gleichen Punktwert wie n1 gesetzt

'Unter die mit n2 berechnete Spalte wird eine Linie gezogen
QVBlatt.Range(BereichText(n2, qvStrataSpalte, n2, qvStrataSpalte + Gesellschaftszahl)).Select
Selection.Borders(xlBottom).Weight = xlHairline
n1 = n2 + 1 'gehe auf neuen Punktwert
Loop 'für die einzelnen Punkteinträge

'Unter die letzte Zeile wird noch eine dicke Linie gezogen
QVBlatt.Range(BereichText(n2, qvStrataSpalte, n2, qvStrataSpalte + Gesellschaftszahl)).Select
Selection.Borders(xlBottom).Weight = xlMedium

'Einfügen dicker Linien für die Funktionsstufen
n1 = qvDatenZeile 'Oberster STRATA-Punktwert
For n = 1 To 11 'für alle 11 möglichen Funktionsstufen
If abPunkt(n) > 0 Then 'Falls die Funktionsstufe nicht definiert wurde, soll auch keine Linie gezogen werden
Do While QVBlatt.Cells(n1, qvStrataSpalte).Value > abPunkt(n)
n1 = n1 + 1
Loop
n2 = n1 'Suche unterstes Auftreten des jeweiligen Punktwertes
Do While QVBlatt.Cells(n1, qvStrataSpalte) = QVBlatt.Cells(n2 + 1, qvStrataSpalte)
n2 = n2 + 1
Loop
QVBlatt.Range(BereichText(n2, qvStrataSpalte, n2, qvStrataSpalte + Gesellschaftszahl)).Select
Selection.Borders(xlBottom).Weight = xlMedium
n1 = n2 + 1 'gehe auf neuen Punktwert
End If
Next n

'Überflüssige STRATA-Punkte löschen
letzteSTRATAZeile = QVGesellschaftsZeile + 1
For n = QVGesellschaftsZeile + 1 To ZeilenNr + QVBlatt.Cells(ZeilenNr, 1).Value
If QVBlatt.Cells(letzteSTRATAZeile, 1).Value = QVBlatt.Cells(n, 1).Value Then
If n > QVGesellschaftsZeile + 1 Then QVBlatt.Cells(n, 1).Value = ""
Else
letzteSTRATAZeile = n
End If
Next

'Unerwünschte Zeilen löschen; Zeilen sind leer!!!
'n1 zeigt auf die aktuelle Zeile
n1 = QVGesellschaftsZeile
Do While QVBlatt.Cells(n1 + 1, qvStrataSpalte).Value <> "ENDE"
n1 = n1 + 1
leer = 1
For n2 = 2 To 52
If QVBlatt.Cells(n1, n2).Value <> "" Then leer = 0
Next n2
If QVBlatt.Cells(n1, 1).Value <= Stratamax And QVBlatt.Cells(n1, 1).Value >= Stratamin Then leer = 0

If leer = 1 Then
QVBlatt.Rows(n1).Select
Selection.Delete Shift:=xlUp
n1 = n1 - 1
End If
Loop
QVBlatt.Range(BereichText(n1, qvStrataSpalte, n1, qvStrataSpalte + Gesellschaftszahl)).Select
Selection.Borders(xlBottom).Weight = xlMedium

' Next n1
End Sub 'QuervergleichErstellen


Sub QVAusdrucken()
Dim n, n1, n2 As Integer
Dim Gesellschaftszahl As Integer

Präliminarien
QVBlatt.Select
'Zahl der Gesellschaften ermitteln
Gesellschaftszahl = 1
Do While QVBlatt.Cells(QVGesellschaftsZeile, qvStrataSpalte + Gesellschaftszahl + 1) <> ""
Gesellschaftszahl = Gesellschaftszahl + 1
Loop
n1 = qvDatenZeile 'Oberste Datenzeile (80 STRATA-Punkte oder so)
For n = 1 To 11 'Für alle 11 möglichen Funktionsstufen...
If abPunkt(n) >= 0 Then 'Nur falls die Funktionsstufe deklariert ist
n2 = n1 'n1 steht automatisch auf der oberen Grenze; Jetzt muß n2 auf die untere Grenze der Funktionsstufe gesetzt werden
Do While QVBlatt.Cells(n2 + 1, qvStrataSpalte) >= abPunkt(n)
n2 = n2 + 1
Loop
Range(BereichText(n1, qvStrataSpalte, n2, qvStrataSpalte + Gesellschaftszahl)).Select
ActiveSheet.PageSetup.PrintArea = Selection.Address
With ActiveSheet.PageSetup
.CenterHeader = "&""Arial,Fett""&24" & Funktionsstufe(n)
End With
ActiveWindow.SelectedSheets.PrintOut Copies:=1
End If
n1 = n2 + 1 'Setzt n1 auf die nächste obere Grenze
Next n

End Sub 'QV Ausdrucken

Function Bestimmtheit(aBereich As Object, bBereich As Object)
'Berechnet das Bestimmtheitsmaß zwischen den angeg. Bereichen
'Berechnet wird die Summe der quadratischen Abweichungen durch die Summe der
'Quadrate und daraus die Wurzel. Die Zahl gibt ungefähr die mittlere Abweichung in Prozent an.
Dim r, r1 As Double
Dim n, i As Integer
Dim a(), u_b()

n = aBereich.Rows.Count
ReDim a(n)
ReDim u_b(n)
'Übergabe der Bereiche in Datenfelder
For i = 1 To n
a(i) = aBereich.Cells(i, 1)
u_b(i) = bBereich.Cells(i, 1)
Next

'Berechne Bestimmtheitsmaß
r = 0
r1 = 0
For i = 1 To n
r1 = r1 + a(i) ^ 2
r = r + (a(i) - u_b(i)) ^ 2
Next i
Bestimmtheit = Sqr(r / r1)
End Function 'Bestimmtheit

Function l2Parameter(aBereich As Range, bBereich As Range) As abcTyp
'Berechnet Ausgleichsfunktion der Art a + b*x + c*x^2
'Die Parameter werden in den Komponenten a, b und c übergeben.
'Aufruf innerhalb von Visual-Basic siehe Funktion l2ParameterA weiter unten

Dim a(), u_b() As Double 'Felder für die Bereiche; variable Länge
Dim Blatt As Object
Dim n, i As Integer
Dim aa, ab, ac, ad, ae, af, ag, ah, ai, aj, ak, al, am, an As Double
Dim a1, a2, a3 As Double

n = aBereich.Rows.Count

ReDim a(n)
ReDim u_b(n)

'Übergabe der Bereiche in Datenfelder
For i = 1 To n
a(i) = aBereich.Cells(i, 1)
u_b(i) = bBereich.Cells(i, 1)
Next

'Berechnen der Parameter
aa = 0: ab = 0: ac = 0: ad = 0: ae = 0: af = 0: ag = 0: ah = 0: ai = 0: aj = 0: ak = 0: al = 0: am = 0: an = 0
For i = 1 To n
If a(i) * u_b(i) <> 0 Then
'Berücksichtigt nur Werte, wenn sowohl x als auch y <>0 sind
ag = ag + 1
ah = ah + a(i)
ai = ai + a(i) * a(i)
aj = aj + a(i) * a(i) * a(i)
ak = ak + a(i) * a(i) * a(i) * a(i)
al = al + u_b(i)
am = am + u_b(i) * a(i)
an = an + u_b(i) * a(i) * a(i)
End If
Next i
aa = ah * ah - ai * ag
ab = ah * ai - aj * ag
ac = ah * al - ag * am
ae = ai * ai - ag * ak
af = ai * al - ag * an


a3 = (ab * ac - aa * af) / (ab * ab - aa * ae)
a2 = (ac - ab * a3) / aa
a1 = (al - a2 * ah - a3 * ai) / ag
l2Parameter.c = a3
l2Parameter.u_b = a2
l2Parameter.a = a1
End Function 'l2Parameter

Function l2ParameterA(aBereich As Object, bBereich As Object)
'Liefert a-Komponente von l2Parameter
'Notwendig, da innerhalb einer Tabelle die Komponenten von l2Parameter nicht erreichbar sind.
l2ParameterA = l2Parameter(aBereich, bBereich).a
End Function 'l2Parametera
Function l2ParameterB(aBereich As Object, bBereich As Object)
'Liefert b-Komponente von l2Parameter
l2ParameterB = l2Parameter(aBereich, bBereich).u_b
End Function 'l2Parameterb
Function l2ParameterC(aBereich As Object, bBereich As Object)
'Liefert c-Komponente von l2Parameter
l2ParameterC = l2Parameter(aBereich, bBereich).c
End Function 'l2Parameterc


Function e2Parameter(aBereich As Range, bBereich As Range) As abcTyp
'Berechnet Ausgleichsfunktion der Art exp(a+b*x)
'Die Parameter werden in den Komponenten a, b und c übergeben.
'Aufruf innerhalb von Visual-Basic siehe Funktion e2ParameterA weiter unten

Dim a(), u_b() As Double 'Felder für die Bereiche
Dim n, i As Integer
Dim aa, ab, ac, ad, ae, af, ag, ah, ai, aj, ak, al, am, an As Double
Dim a1, a2, a3 As Double

n = aBereich.Rows.Count

ReDim a(n)
ReDim u_b(n)

'Übergabe der Bereiche in Datenfelder
For i = 1 To n
a(i) = aBereich.Cells(i, 1)
Next
For i = 1 To n
u_b(i) = bBereich.Cells(i, 1)
Next

'Berechnen der Parameter
aa = 0: ab = 0: ac = 0: ad = 0: ae = 0: af = 0: ag = 0: ah = 0: ai = 0: aj = 0: ak = 0: al = 0: am = 0: an = 0
For i = 1 To n
If a(i) * u_b(i) <> 0 Then
'Berücksichtigt nur Werte, wenn sowohl x als auch y <>0 sind
ag = ag + 1
ah = ah + a(i)
ai = ai + a(i) * a(i)
aj = aj + a(i) * a(i) * a(i)
ak = ak + a(i) * a(i) * a(i) * a(i)
al = al + Log(u_b(i))
am = am + Log(u_b(i)) * a(i)
an = an + Log(u_b(i)) * a(i) * a(i)
End If
Next i
aa = ah * ah - ai * ag
ab = ah * ai - aj * ag
ac = ah * al - ag * am
ae = ai * ai - ag * ak
af = ai * al - ag * an

a3 = (ab * ac - aa * af) / (ab * ab - aa * ae)
a2 = (ac - ab * a3) / aa
a1 = (al - a2 * ah - a3 * ai) / ag
e2Parameter.c = a3
e2Parameter.u_b = a2
e2Parameter.a = a1

End Function 'e2Parameter

Function e2ParameterA(aBereich As Object, bBereich As Object)
'Liefert a-Komponente von e2Parameter
'Notwendig, da innerhalb einer Tabelle die Komponenten von e2Parameter nicht erreichbar sind.
e2ParameterA = e2Parameter(aBereich, bBereich).a
End Function 'e2Parametera
Function e2ParameterB(aBereich As Object, bBereich As Object)
'Liefert b-Komponente von e2Parameter
e2ParameterB = e2Parameter(aBereich, bBereich).u_b
End Function 'e2Parameterb
Function e2ParameterC(aBereich As Object, bBereich As Object)
'Liefert c-Komponente von e2Parameter
e2ParameterC = e2Parameter(aBereich, bBereich).c
End Function 'e2Parameterc

Function l1Parameter(aBereich As Range, bBereich As Range) As abcTyp
'Berechnet Ausgleichsfunktion der Art a + b*x
'Die Parameter werden in den Komponenten a und b übergeben.
'Aufruf innerhalb von Visual-Basic siehe Funktion l1ParameterA weiter unten

Dim n, i As Integer
Dim a(), u_b() As Double
Dim aa, ab, ac, ad, ae As Double
Dim a1, a2 As Double

n = aBereich.Rows.Count

ReDim a(n)
ReDim u_b(n)


'Übergabe der Bereiche in Datenfelder
For i = 1 To n
a(i) = aBereich.Cells(i, 1)
Next
For i = 1 To n
u_b(i) = bBereich.Cells(i, 1)
Next

'Berechnen der Parameter
aa = 0: ab = 0: ac = 0: ad = 0: ae = 0
For i = 1 To n
If a(i) * u_b(i) <> 0 Then
'Berücksichtigt nur Werte, wenn sowohl x als auch y <>0 sind
aa = aa + 1
ab = ab + a(i)
ac = ac + a(i) * a(i)
ad = ad + u_b(i)
ae = ae + u_b(i) * a(i)
End If
Next i

a2 = (aa * ae - ab * ad) / (aa * ac - ab * ab)
a1 = (ad - a2 * ab) / aa
l1Parameter.u_b = a2
l1Parameter.a = a1
End Function 'l1Parameter

Function l1ParameterA(aBereich As Object, bBereich As Object)
'Liefert a-Komponente von l1Parameter
'Notwendig, da innerhalb einer Tabelle die Komponenten von l1Parameter nicht erreichbar sind.
l1ParameterA = l1Parameter(aBereich, bBereich).a
End Function 'l1Parametera
Function l1ParameterB(aBereich As Object, bBereich As Object)
'Liefert b-Komponente von l1Parameter
l1ParameterB = l1Parameter(aBereich, bBereich).u_b
End Function 'l1Parameterb

Function BereichText(ByVal u_b As Integer, ByVal a As Integer, ByVal d As Integer, ByVal c As Integer) As String
'Wandelt die vier Zahlen in eine TextBereichsangabe um; zB: 4;2;6;8 in "b4:h6"
'Benutzung: Bereich( BereichText(2;4;5;4) )
Dim aa, cc As Integer

aa = Fix(a / 26)
a = a - aa * 26
cc = Fix(c / 26)
c = c - cc * 26
If aa > 0 Then
BereichText = Chr(aa + 64)
Else
BereichText = ""
End If
BereichText = BereichText & Chr(a + 64) & u_b & ":"
If cc > 0 Then
BereichText = BereichText & Chr(cc + 64)
End If
BereichText = BereichText & Chr(c + 64) & d
End Function 'BereichText

Function e1Parameter(aBereich As Range, bBereich As Range) As abcTyp
'Berechnet Ausgleichsfunktion der Art a + b*x + c*x^2
'Die Parameter werden in den Komponenten a, b und c übergeben.
'Aufruf innerhalb von Visual-Basic siehe Funktion e1ParameterA weiter unten

Dim n, i As Integer
Dim a(), u_b() As Double
Dim aa, ab, ac, ad, ae As Double
Dim a1, a2 As Double

n = aBereich.Rows.Count

ReDim a(n)
ReDim u_b(n)


'Übergabe der Bereiche in Datenfelder
For i = 1 To n
a(i) = aBereich.Cells(i, 1)
Next
For i = 1 To n
u_b(i) = bBereich.Cells(i, 1)
Next

'Berechnen der Parameter
aa = 0: ab = 0: ac = 0: ad = 0: ae = 0
For i = 1 To n
If a(i) * u_b(i) <> 0 Then
'Berücksichtigt nur Werte, wenn sowohl x als auch y <>0 sind
aa = aa + 1
ab = ab + a(i)
ac = ac + a(i) * a(i)
ad = ad + Log(u_b(i))
ae = ae + Log(u_b(i)) * a(i)
End If
Next i

If aa * ac - ab * ab <> 0 Then
a2 = (aa * ae - ab * ad) / (aa * ac - ab * ab)
Else: a2 = 0
End If
If aa <> 0 Then
a1 = (ad - a2 * ab) / aa
Else: a1 = 0
End If
e1Parameter.u_b = a2
e1Parameter.a = a1
End Function 'e1Parameter

Function e1ParameterA(aBereich As Object, bBereich As Object)
'Liefert a-Komponente von e1Parameter
'Notwendig, da innerhalb einer Tabelle die Komponenten von e1Parameter nicht erreichbar sind.
e1ParameterA = e1Parameter(aBereich, bBereich).a
End Function 'e1Parametera
Function e1ParameterB(aBereich As Object, bBereich As Object)
'Liefert b-Komponente von e1Parameter
e1ParameterB = e1Parameter(aBereich, bBereich).u_b
End Function 'e1Parameterb


Sub StandardFußzeile()
Application.ScreenUpdating = False
With ActiveChart.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = "&8©STRATA Unternehmensberatung GmbH"
.CenterFooter = ""
.RightFooter = "&8&N - &B - &D"
End With
End Sub

Function NummerAusText(a As String) As Integer 'Berechnet aus z.B. AB die zugehörige Spaltennr 28
Dim t1 As String
Dim n As Integer

t1 = Left(UCase(a), 1)
n = Asc(t1) - 64
If Len(a) > 1 Then
t1 = Mid(UCase(a), 2, 1)
n = n * 26 + Asc(t1) - 64
End If
NummerAusText = n
End Function 'Nummeraustext

Function SpaltenNr(a As Variant) As Integer
'Wandelt Zeichenfolgen in Spaltennr um
Dim t1 As String
Dim n As Integer

On Error GoTo FehlerStart1 'Falls in a keine Zahl steht sondern Text...
n = CInt(a)
GoTo FehlerEnde1
FehlerStart1:
t1 = a
n = NummerAusText(t1)

FehlerEnde1:
SpaltenNr = n
End Function 'SpaltenNr

Sub e2ParameterEinfügen()
Dim Bereich1, Bereich2, Text As String
Dim Z, S As Integer
Dim Parameter As abcTyp


Z = ActiveCell.Row
S = ActiveCell.Column
Text = CStr(Cells(Z - 1, S).Value)

Bereich1 = Left(Text, InStr(Text, ";") - 1)
Bereich2 = Right(Text, Len(Text) - InStr(Text, ";"))

Parameter = e2Parameter(Range(Bereich1), Range(Bereich2))

Cells(Z, S).Value = Parameter.a
Cells(Z + 1, S).Value = Parameter.u_b
Cells(Z + 2, S).Value = Parameter.c
End Sub 'e2ParameterEinfügen

Sub e1ParameterEinfügen()
Dim Bereich1, Bereich2, Text As String
Dim Z, S As Integer
Dim Parameter As abcTyp

Z = ActiveCell.Row
S = ActiveCell.Column
Text = CStr(Cells(Z - 1, S).Value)

Bereich1 = Left(Text, InStr(Text, ";") - 1)
Bereich2 = Right(Text, Len(Text) - InStr(Text, ";"))

Parameter = e1Parameter(Range(Bereich1), Range(Bereich2))

Cells(Z, S).Value = Parameter.a
Cells(Z + 1, S).Value = Parameter.u_b
Cells(Z + 2, S).Value = 0
End Sub 'e1ParameterEinfügen

Sub l2ParameterEinfügen()
Dim Bereich1, Bereich2, Text As String
Dim Z, S As Integer
Dim Parameter As abcTyp

Z = ActiveCell.Row
S = ActiveCell.Column
Text = CStr(Cells(Z - 1, S).Value)

Bereich1 = Left(Text, InStr(Text, ";") - 1)
Bereich2 = Right(Text, Len(Text) - InStr(Text, ";"))

Parameter = l2Parameter(Range(Bereich1), Range(Bereich2))

Cells(Z, S).Value = Parameter.a
Cells(Z + 1, S).Value = Parameter.u_b
Cells(Z + 2, S).Value = Parameter.c
End Sub 'l2ParameterEinfügen

Sub l1ParameterEinfügen()
Dim Bereich1, Bereich2, Text As String
Dim Z, S As Integer
Dim Parameter As abcTyp

Z = ActiveCell.Row
S = ActiveCell.Column
Text = CStr(Cells(Z - 1, S).Value)

Bereich1 = Left(Text, InStr(Text, ";") - 1)
Bereich2 = Right(Text, Len(Text) - InStr(Text, ";"))

Parameter = l1Parameter(Range(Bereich1), Range(Bereich2))

Cells(Z, S).Value = Parameter.a
Cells(Z + 1, S).Value = Parameter.u_b
Cells(Z + 2, S).Value = 0
End Sub 'l1ParameterEinfügen
r.mueller
Gast


Verfasst am:
02. Aug 2009, 22:16
Rufname:


AW: Zeilenumbruch mit angepasster Zeilenhöhe über Excel VBA - AW: Zeilenumbruch mit angepasster Zeilenhöhe über Excel VBA

Nach oben
       Version: Office 2007

Hallo

Am End nachdem alle fertig eingefügt wurde dies:

Code:

Cells.WrapText = True
Cells.Rows.AutoFit


Gruß
r.mueller
Bryan
Gast


Verfasst am:
02. Aug 2009, 23:20
Rufname:

AW: Zeilenumbruch mit angepasster Zeilenhöhe über Excel VBA - AW: Zeilenumbruch mit angepasster Zeilenhöhe über Excel VBA

Nach oben
       Version: Office 2007

Super!!!

Vielen Dank für die schnelle Antwort!

Wusste doch, dass es ein simpler Befehl ist, für Leute, die sich auskennen! Wink)

Schönen Gruß
Bryan Razz
Bryan
Gast


Verfasst am:
03. Aug 2009, 08:55
Rufname:

AW: Zeilenumbruch mit angepasster Zeilenhöhe über Excel VBA - AW: Zeilenumbruch mit angepasster Zeilenhöhe über Excel VBA

Nach oben
       Version: Office 2007

Da fällt mir noch eine Sache auf. Kann man die erste Zeile von dem Zeilenumbruch ausnehmen?

Dank Euch!!
Bryan
Gast


Verfasst am:
03. Aug 2009, 14:54
Rufname:

AW: Zeilenumbruch mit angepasster Zeilenhöhe über Excel VBA - AW: Zeilenumbruch mit angepasster Zeilenhöhe über Excel VBA

Nach oben
       Version: Office 2007

Help, please!! Laughing
r.mueller
Gast


Verfasst am:
03. Aug 2009, 15:30
Rufname:


AW: Zeilenumbruch mit angepasster Zeilenhöhe über Excel VBA - AW: Zeilenumbruch mit angepasster Zeilenhöhe über Excel VBA

Nach oben
       Version: Office 2007

Hallo

Code:

Cells.WrapText = True
Rows(1).WrapText = False
Cells.Rows.AutoFit

Gruß
r.mueller
Neues Thema eröffnen   Neue Antwort erstellen Alle Zeiten sind
GMT + 1 Stunde

Diese Seite Freunden empfehlen

Seite 1 von 1
Gehe zu:  
Du kannst Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
Du kannst Dateien in diesem Forum nicht posten
Du kannst Dateien in diesem Forum herunterladen

Verwandte Themen
Forum / Themen   Antworten   Autor   Aufrufe   Letzter Beitrag 
Keine neuen Beiträge Excel Formeln: Elementabhängiger Zeilenumbruch bei Verkettungen 7 Wurstkuchen 118 10. Dez 2013, 09:12
Gast Elementabhängiger Zeilenumbruch bei Verkettungen
Keine neuen Beiträge Excel Formeln: Text einer Zelle bei Zeilenumbruch in mehrere Zellen 2 plasticbl8 111 28. Nov 2013, 11:38
plasticbl8 Text einer Zelle bei Zeilenumbruch in mehrere Zellen
Keine neuen Beiträge Excel Formeln: Zellen zusammanführen mit Zeilenumbruch und Formaten 4 Kiamolo 106 21. Okt 2013, 09:25
Kiamolo Zellen zusammanführen mit Zeilenumbruch und Formaten
Keine neuen Beiträge Excel Formeln: Verketten mit Zeilenumbruch in der Zelle 5 wuselking 310 18. Feb 2013, 16:10
wuselking Verketten mit Zeilenumbruch in der Zelle
Keine neuen Beiträge Excel Formeln: manuellen Zeilenumbruch in Tabelle suchen und ersetzen 2 trommlertom 430 02. Nov 2012, 11:34
trommlertom manuellen Zeilenumbruch in Tabelle suchen und ersetzen
Keine neuen Beiträge Excel Formeln: Zeilenumbruch aus anderen Zeile übernehmen 8 Excelnap 304 18. Aug 2012, 20:14
neopa Zeilenumbruch aus anderen Zeile übernehmen
Keine neuen Beiträge Excel Formeln: Zellen verbinden mit Zeilenumbruch 4 Gast 1222 16. März 2011, 13:29
Gast Zellen verbinden mit Zeilenumbruch
Keine neuen Beiträge Excel Formeln: bei leerzeichen zeilenumbruch erzwingen 4 deep_dive 3155 24. Sep 2010, 10:55
deep_dive bei leerzeichen zeilenumbruch erzwingen
Keine neuen Beiträge Excel Formeln: Wenn TabelleX Feld Y=1 Dann kopiere Zeile sonst Zeilenhöhe=0 2 Bebbionist 497 08. Apr 2009, 20:53
Bebbionist Wenn TabelleX Feld Y=1 Dann kopiere Zeile sonst Zeilenhöhe=0
Keine neuen Beiträge Excel Formeln: <br> ersetzen durch Zeilenumbruch 5 hanskalk 3666 17. März 2008, 19:05
ae <br> ersetzen durch Zeilenumbruch
Keine neuen Beiträge Excel Formeln: Zeilenumbruch aus anderem Tabellenblatt übernehmen? 5 frsh- 1326 20. Dez 2007, 20:35
frsh- Zeilenumbruch aus anderem Tabellenblatt übernehmen?
Keine neuen Beiträge Excel Formate: In einem Feld eine Zweite Zeile (Zeilenumbruch) 2 Tookchub 906 09. Aug 2007, 14:30
Tookchub In einem Feld eine Zweite Zeile (Zeilenumbruch)
 

----> Diese Seite Freunden empfehlen <------ Impressum - Besuchen Sie auch: Microsoft-Excel Diagramme