Office: Excel 2003: autom. Zeilenhöhe bei verbundenen Zellen

Hallo Excel-/VBA-Päpste,

ich stehe vor einem für die Profis von Euch vermutlich nicht ganz so großen Problem:

Ich habe eine Datei mit verbundenen Zellen. Die in den einzelnen Zellen eingegebnenen Texte sind zum Teil so groß, dass ein Zeilenumbruch notwendig ist und die Zeilenhöhe angepasst werden muss. Zu diesem Zweck habe ich das entsprechende Makro von der "www.herber.de" in meiner Datei eingebaut. Per Button funktioniert das Makro auch problemlos.

Nun soll das Ganze aber automatisch bereits beim Öffnen der Datei aktiviert werden und das Anpassen der Zeilenhöhe selbstständig durchführen, sobald die Zellen gefüllt wurden. Zu diesem Zweck habe ich das Makro entsprechend verändert und in mein Tabellenblatt gelegt. Nun passiert aber folgendes: Sobald man seinene mehrzeiligen Text in die Zelle eingetragen hat und die Zelle verlässt läuft das Makro, jedoch in der dann aktiven Zelle.

In dem Makro müsste also eine Funktion integriert werden, die, nachdem festgestellt wurde, dass die Zelle gerade verändert wurde, zu dieser Zelle zurückkehrt, sie dann ändert und wieder zu der nächsten Zelle wechselt.

Hier nun mein benutzter Code:


Private Sub Worksheet_Change(ByVal Target As Range)

ActiveSheet.Unprotect

Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim ActiveCellWidth As Single, PossNewRowHeight As Single
If ActiveCell.Row > 11 And ActiveCell.Row < 19 Then
If ActiveCell.MergeCells Then
With ActiveCell.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
ActiveCellWidth = ActiveCell.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = ActiveCellWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
End If
End If
Application.ScreenUpdating = True

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

End Sub

Für eine Lösung wäre ich Euch wirklich dankbar.

:)

 

Hi,

..... ersetze ActiveCell durch Target

 

Hallo Chris,

zunächst einmal vielen Dank für die sehr schnelle Antwort.

Da ich wirklich nur laienhafte Kenntnisse in VBA habe, müsstest Du mir noch erklären, wo genau ich ActiveCell durch Target ersetzen muss, etwa an jeder?

Gruß, dobbelcop

 

Hi,

ja *Smilie, den activecell willst du ja nicht.
activecell =aktive Zelle
Target = geänderte Zelle

 

Hi Chris,

nachdem ich nun den Code entsprechend geändert habe, funktoniert es leider immer noch nicht. Selbst als direkt ausgeführtes Makro nicht. *confused.gif*

So sieht der komplette Code momentan aus. Wo steckt da der Wurm drin???

Private Sub Worksheet_Change(ByVal Target As Range)

ActiveSheet.Unprotect

Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim TargetWidth As Single, PossNewRowHeight As Single
If Target.Row > 11 And Target.Row < 19 Then
If Target.MergeCells Then
With Target.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
TargetWidth = Target.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + MergedCellRgWidth
Next
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = TargetWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
End If
End With
End If
End If
Application.ScreenUpdating = True

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

End Sub

Vielleicht hast Du ja noch einen Lösungsvorschlag parat.

Gruß, dobbelcop

 

Hi,

im Code sind so viel Einschränkungen....
Bei mir funktioniert es.

nur dürfen z.B bei deinen verbunden Zellen keine Zeilen verbunden werden,

With Target.MergeArea
If .Rows.Count = 1
denn dann würde es schon nicht mehr gehen.
usw. usw.
Wenn jetzt aber Spalten verbunden werden wird versucht die erste Spalte anzupassen?
das ganze darf aber nur zwischen Zeile 12 und 18 sein
ist die Zelle keine verbundene Zelle wird auch nichts gemacht...
ist kein Zeilenumbruch aktiv wird auch nichts gemacht....

p.s Direkt ausführen geht bei Target mit Sicherheit nicht *wink.gif*
Wenn "natürliche Feinde" =verbundene Zellen in der Mappe enthalten sind gibt es immer Probleme.

 

Hallo nochmal,

Du bist echt fit - Respekt! Vielen Dank, dass Du Dir die Zeit nimmst. Langsam kommen wir dem Ziel näher.

Allerdings kommt doch noch die ein oder andere Fehlermeldung, bzw. sperrt nach Anpassen der Höhe die Zelle, so dass eine Korrektur der Eingabe nicht mehr möglich ist (zumindest nicht, ohne den Blattschutz afuzuheben). U.a. versucht der Code offenbar auch die Spaltenbreite anzupassen. Das soll er aber gar nicht.

Eigentlich soll der Code lediglich die Zeilenhöhe der verbundenen Zellen anpassen, sobald etwas eingegeben wurde.

Vielleicht hast Du ja noch Zeit und Muße, Dir die Datei einmal anzusehen.

Ich wäre Dir wirklich dankbar.

 

Hi,

versuche mal das

Code:

 

Hallo Chris,

ich habe den "neuen" Code probiert. Leider funktioniert er bei mir nicht. Allerdings bin ich mit dem ursprünglichen Code weiter gekommen. Leicht modifiziert funktionert er jetzt.

Es gibt nur noch ein Problem, das ich nicht in den Griff bekomme: Wenn ich eine der bereits beschriebenen Zellen mit der Escape-Tast lösche erscheint eine VBA-Fehlermeldung (Laufzeitfehler '1004' - Anwendungs- oder objektdefinierter Fehler), die Abarbeitung der Befehle wird natürlich unterbrochen.

Gibt es die Möglichkeit, einen Befehl einzubinden, der die Zelle bei ESC leert?

Hier der nun mit Deiner Hilfe funktionierende Code:

Private Sub Worksheet_Change(ByVal Target As Range)

ActiveSheet.Unprotect

Dim CurrentRowHeight As Single, MergedCellRgWidth As Single
Dim CurrCell As Range
Dim TargetWidth As Single, PossNewRowHeight As Single
Dim iX As Integer
If Target.MergeCells Then
With Target.MergeArea
If .Rows.Count = 1 And .WrapText = True Then
Application.ScreenUpdating = False
CurrentRowHeight = .RowHeight
TargetWidth = Target.ColumnWidth
For Each CurrCell In Selection
MergedCellRgWidth = CurrCell.ColumnWidth + _
MergedCellRgWidth
iX = iX + 1
Next
MergedCellRgWidth = MergedCellRgWidth + (iX - 1) * 0.71
.MergeCells = False
.Cells(1).ColumnWidth = MergedCellRgWidth
.EntireRow.AutoFit
PossNewRowHeight = .RowHeight
.Cells(1).ColumnWidth = TargetWidth
.MergeCells = True
.RowHeight = IIf(CurrentRowHeight > PossNewRowHeight, _
CurrentRowHeight, PossNewRowHeight)
.Locked = False
End If
End With
End If
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingRows:=True
ActiveSheet.EnableSelection = xlUnlockedCells

End Sub

Gruß und schon einmal ein schönes Wochenende, dobbelcop

 

Hi,

leider habe ich im Moment keine Zeit mehr.....

hier noch mein Code der nicht funktioniert in der Mappe hinterlegt *Smilie
Ich hatte im Code ohne Blattschutz gearbeitet.
diese Zeile habe ich noch hinzugefügt.
da reicht eigentlich eine mit Userinterfaceonly

 

Hi,

so ich habe nun deinen Text mal durchgelesen...,

mit ESC wird nicht gelöscht?
Wenn Du meinen Code nimmst kannst Du die Zelle ganz normal mit ENTF
löschen.

 

Hallo Chris,

Du hast natürlich recht. Mit ESC wird natrlich nicht gelöscht. Ich meine auch die DEL- oder Entfernen-Taste - sorry.

Dein Code funktioniert bestens, hat allerdings ein Manko, deswegen hatte ich es mit dem anderen probiert:

Du hast drei feste Zellbezüge eingebaut:

Select Case Target.Address(0, 0)
Case "A28", "B29", "A32"

Mein Formular wird aber - ebenfalls über Makros - kopiert und unter das bereits bestehende eingefügt. Auch hier soll die Zeilenhöhe automatisch angepasst werden. Der Zellbezug darf daher nicht starr sein, sondern variabel.

Ich hänge Dir die aktuelle Datei mit allen Makros noch einmal an. Vielleicht weißt Du rat. Der Fehler tritt tatsächlich nur auf, wenn man die Ent-Tast nutzt. Wenn man eine bereits beschriebene Zelle einfach mit der Back-Taste löscht, funktioniert alles bestens.

 

Hi,

Code:

übrigens wenn das jetzt in x Mappen benötigt wird. Würde ich das in eine Klasse geben und über (WithEvents) steuern und das ganze als Add-in einbinden. Aber das hängt natürlich davon ab, wer die "User" sind und was mit den Mappen weiterhin passiert.

Vorteil dabei ist das die Mappen ohne Code sind. Nachteil könnte sein das die Mappen ohne Code sind. ^^. Wie gesagt hängt davon ab was mit den Mappen in Folge passieren sollte.