Formeln "transponiert ausfüllen"
U_Fle...@news.rhein-zeitung.de
Christian Friedrich
füge eine Zeile der Tabelle erst einmal in der alten Form in das neue
Tabellenblatt ein und ergänze die Formeln. Transponiere nun die Zeile durch
Kopieren --> Einfügen --> Transponieren zu einer Spalte. Nun können die
restlichen Formeln durch "rüberziehen" ergänzt werden.
--
Mit freundlichen Grüßen
Christian Friedrich
Mitglied von Microsoft CLIP (Community Leader/Influencer Program)
Workstream.de http://www.workstream.de/ | http://www.e-workstream.com/
arno
bitte keine html-postings, stell um auf nur text.
>> richtig auszufüllen?
Excel machts eh richtig :)
Google mal nach einem Addin "Transpose Links", das kann was du
möchtest.
Ich hab mir das Ding umgebaut (Übersetzung, sinnloses Zeug gelöscht wie
Undo, auto_open) und in die personl.xls eingefügt und mit einem Button
auf der Menüleiste verknüpft, hab's beigelegt.
arno
dieses Makro in ein neues, leeres Modul der personl.xls kopieren:
Option Private Module
Option Explicit
Dim RestoreRange As Range
Dim TargetRange As Range
Dim SourceRange As Range
Dim SourceWorkbook As Workbook
Dim SourceWorksheet As Worksheet
Dim DisableUndoOK As Boolean
Dim CellsCBEnabled As Boolean
Dim boolColAnchor As Boolean
Dim boolRowAnchor As Boolean
Const PROJ_TITLE As String = "Zellverknüpfungen transponieren"
Sub TranposeLinks()
' Written by Bernie Deitrick 12/12/2001
' With a lot of help from J.E. McGimpsey and John Walkenbach
' Modified 12/13/2001 to include format pasting
' Modified 12/14/2001 to include Undo
' Undo routine based on JW's technique
Dim myCell2 As Range
Dim i As Integer
Dim j As Integer
Dim PrefixString As String
Dim ErrString As String
Dim CalcMode As Integer
On Error GoTo ErrHandler
' JW #2 corollary: The user starts with multiple sheets selected
ErrString = "Sie dürfen nur ein Blatt ausgewählt haben."
If ActiveWindow.SelectedSheets.Count > 1 Then Err.Raise 1
' JW's #4. If the original selection is not a Range
' If so, the first set statement will
' raise the following error message:
ErrString = "Sie müssen mit einer Zelle" & _
Chr(10) & "oder einem gewählten Zellbereich anfangen."
Set SourceRange = Selection
Set SourceWorksheet = ActiveSheet
Set SourceWorkbook = ActiveWorkbook
' JW's #2. The user starts with a multiple selection.
' Raise the error with the following message
ErrString = "Sie können nur einen durchgehenden Block von Zellen
transponieren."
If SourceRange.Areas.Count > 1 Then Err.Raise 1
' JW's #5. The selection consists of an entire column or columns
' Raise the error with the following message
ErrString = "Sie können nur max. 256 Zeilen transponieren."
If SourceRange.Rows.Count > 256 Then Err.Raise 1
'Reset the Error string in case user cancels on anchor range selection
ErrString = "Abbruch durch Benutzer."
Do
Set TargetRange = Application.InputBox( _
"Wählen Sie die Zielzelle (linke obere Bereichszelle) für die
transponierten Links.", _
Title:=PROJ_TITLE, Type:=8)
On Error GoTo 0
' For poor selection of the anchor cell, use message boxes to
inform,
' then set the TargetRange range object to nothing to prevent
further
' processing and to eventually return to the top of the Do Loop.
' JW's #6. The user selects more than one cell in the InputBox
' Offer to use the first cell
If Not TargetRange Is Nothing Then
If TargetRange.Cells.Count > 1 Then
If MsgBox("Möchten Sie " & _
TargetRange.Cells(1, 1).Address(False, False) & _
" Zielzelle (linke obere Bereichszelle des
Zielbereichs) verwenden?", _
vbYesNo, Title:=PROJ_TITLE) = vbNo Then
Set TargetRange = Nothing
Else
Set TargetRange = TargetRange(1, 1)
End If
End If
End If
' JW's #8. You run out of columns when transposing a vertical
range.
' Check for adequate columns
If Not TargetRange Is Nothing Then
If TargetRange.Column - 1 + SourceRange.Rows.Count > 256 Then
MsgBox "Sie müssen eine Zelle innerhalb von Spalte(n) " & _
Range(Columns(1), Columns(257 -
SourceRange.Rows.Count)).Address(False, False) _
& " wählen."
Set TargetRange = Nothing
End If
End If
' JW's #7. The destination range overlaps
' with the source range (circ ref error)
' Check for overlap of ranges if on the same worksheet
If Not TargetRange Is Nothing Then
If TargetRange.Parent Is SourceRange.Parent Then
If Not
Intersect(TargetRange.Resize(SourceRange.Columns.Count, _
SourceRange.Rows.Count), SourceRange) Is Nothing
Then
MsgBox "Die transponierten Ausgabezellen werden " & _
"die ursprüngliche Auswahl überschneiden." &
Chr(10) & _
"Bitte wählen Sie eine andere linke obere
Zielzelle.", _
vbOKOnly, PROJ_TITLE
Set TargetRange = Nothing
End If
End If
End If
' JW's #1. The destination range is protected.
' JW's #3. The destination sheet is protected.
' #1 is only important if #3 is true.
' If it is, check for locked cells.
If Not TargetRange Is Nothing Then
If TargetRange.Parent.ProtectContents = True Then
For Each myCell2 In TargetRange.Resize( _
SourceRange.Columns.Count, SourceRange.Rows.Count)
If myCell2.Locked = True Then
Set TargetRange = Nothing
End If
Next myCell2
End If
If TargetRange Is Nothing Then
MsgBox "Eine oder mehrere Ziezellen " & _
"sind gegenwärtig geschützt." & _
Chr(10) & "Bitte wählen Sie nur ungeschützte Zellen, "
& _
"oder Zellen eines ungeschützten Blattes.", _
vbOKOnly, PROJ_TITLE
End If
End If
' Check for filled cells
' My only original anchor cell check
' Of course, it is the least important
If Not TargetRange Is Nothing Then
If Application.WorksheetFunction.CountBlank( _
TargetRange.Resize(SourceRange.Columns.Count,
SourceRange.Rows.Count)) <> _
SourceRange.Cells.Count Then
If MsgBox("Möchten Sie existierende Zellen überschreiben?",
_
vbYesNo, PROJ_TITLE) = vbNo Then
Set TargetRange = Nothing
End If
End If
End If
On Error GoTo ErrHandler
Loop Until Not TargetRange Is Nothing
With Application
.ScreenUpdating = False
' Preserve calc mode before turning off calcs
CalcMode = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
' I didn't want to paste formats as a default, (to get merging, etc.),
' since pastelinks doesn't normally paste formatting, but I will offer
' it as a final option. If declined, then the links created will be
' similar to the default style Excel Pastelinks, with merged cells in
the
' source range ignored.
' If the target sheet is currently protected, and the format to be
pasted
' includes locked cells, then the currently unlocked cells will become
' locked if the source cells are locked. That will prevent the undo
from
' working. Check for that condition and ask the user what to do.
DisableUndoOK = False
If MsgBox("Formatierungen übernehmen?", vbYesNo, PROJ_TITLE) = vbYes
Then
If TargetRange.Parent.ProtectContents = True Then
For Each myCell2 In SourceRange
If myCell2.Locked = True Then
If Not DisableUndoOK Then
If MsgBox("Das einzufügende Format beinhaltet
geschützte Zellen." & _
Chr(10) & "Das Blatt für das Einfügen ist
geschützt," & _
Chr(10) & "aber der Einfügebereich ist gerade
ungeschützt." & _
Chr(10) & "Dies wird ein Rückgangigmachen des
Transponierens verhindern." & _
Chr(10) & "Möchten Sie fortfahren?", _
vbYesNo, PROJ_TITLE) = vbNo Then
Exit Sub
Else
DisableUndoOK = True
End If
End If
End If
Next myCell2
End If
SourceRange.Copy
TargetRange.PasteSpecial Paste:=xlFormats, Transpose:=True
Application.CutCopyMode = False
End If
'Tightened-up code by J.E. McGimpsey
' Create the reference formula step by step, as needed
' If link is across workbooks ....
If Not SourceWorkbook Is TargetRange.Parent.Parent Then PrefixString =
_
"[" & SourceWorkbook.Name & "]"
' If link is across worksheets ....
If Not SourceWorksheet Is TargetRange.Parent Then PrefixString = _
"'" & PrefixString & SourceWorksheet.Name & "'!"
' Add the equal sign
PrefixString = "=" & PrefixString
'Put the link formulas into the link area
boolColAnchor = False
boolRowAnchor = False
Application.ScreenUpdating = True
If SourceRange.Columns.Count > 1 Then
If MsgBox("Absolute Spaltenbezüge verwenden (z.B. $A1)?", vbYesNo,
PROJ_TITLE) = vbYes Then
boolColAnchor = True
End If
End If
If SourceRange.Rows.Count > 1 Then
If MsgBox("Absolute Zeilenbezüge verwenden (z.B. A$1)?", vbYesNo,
PROJ_TITLE) = vbYes Then
boolRowAnchor = True
End If
End If
With SourceRange
For i = 1 To .Columns.Count
For j = 1 To .Rows.Count
TargetRange(i, j).Formula = _
PrefixString & .Item(j, i).Address(boolRowAnchor,
boolColAnchor)
Next j
Next i
End With
'With SourceRange
' For i = 1 To .Columns.Count
' For j = 1 To .Rows.Count
' TargetRange(i, j).Formula = _
' PrefixString & .Item(j, i).Address
' Next j
' Next i
'End With
' Turn calc back to original,
' clear the copy (if done),
' and turn on screen updating
With Application
.Calculation = CalcMode
.ScreenUpdating = True
.DisplayAlerts = True
End With
Exit Sub
' Error handler shows the specific error condition
' regarding the initial selection,
' as set in the variable ErrString
ErrHandler:
If ErrString <> "Abbruch durch Benutzer." Then
MsgBox ErrString, vbOKOnly, PROJ_TITLE
End If
End Sub
Christian Friedrich
Handgriffen erledigen lässt ;-) (no offence)
--
Mit freundlichen Grüßen
Christian Friedrich
Mitglied von Microsoft CLIP (Community Leader/Influencer Program)
Workstream.de http://www.workstream.de/ | http://www.e-workstream.com/
arno
genau, har, har, har...
das muss schon sein, wenn doch excel alles falsch macht ;)
Vor Ewigkeiten hab ich das Ding aufbereitet, vielleicht nützt es ja mal
jemanden. *grosszügigentaghab*
arno
Christian Friedrich
überflüssigen Features gelöscht hast ;-)
--
Mit freundlichen Grüßen
Christian Friedrich
Mitglied von Microsoft CLIP (Community Leader/Influencer Program)
Workstream.de http://www.workstream.de/ | http://www.e-workstream.com/
arno
schnell zu eliminieren.
ulffle...@news.rhein-zeitung.de
schrieb:
>Hallo Ulf,
>
>füge eine Zeile der Tabelle erst einmal in der alten Form in das neue
>Tabellenblatt ein und ergänze die Formeln. Transponiere nun die Zeile durch
>Kopieren --> Einfügen --> Transponieren zu einer Spalte. Nun können die
>restlichen Formeln durch "rüberziehen" ergänzt werden.
Hallo Christian,
so einfach scheint es aber nicht zu sein. Beim Kopieren an die selbe
Stelle bekomme ich den Fehler "ungültige Markierung", beim Kopieren an
eine andere Stelle bekommt die Formel einen Bezugsfehler.
Ich werde mal Arnos Makro ausprobieren.
Gruß Ulf
ulffle...@news.rhein-zeitung.de
>Hi U_Fle...@news.rhein-zeitung.de,
>
>bitte keine html-postings, stell um auf nur text.
Ich hoffe, so geht es jetzt besser. An der Sache mit den richtigen
Absenderangaben bin ich noch dran.
>>> richtig auszufüllen?
>
>Excel machts eh richtig :)
>
>Google mal nach einem Addin "Transpose Links", das kann was du
>möchtest.
>
>Ich hab mir das Ding umgebaut (Übersetzung, sinnloses Zeug gelöscht wie
>Undo, auto_open) und in die personl.xls eingefügt und mit einem Button
>auf der Menüleiste verknüpft, hab's beigelegt.
>
>arno
>
Das Makro tut genau was ich möchte. Ich habe jetzt nur das Problem,
daß es bei den Makros nicht angezeigt wird (ALT+F8). Bisher hatte ich
alle Makros in Modul1. Dieses habe ich jetzt in Modul2 kopiert. Was
muß ich ändern?
Gruß Ulf
arno
> Das Makro tut genau was ich möchte. Ich habe jetzt nur das Problem,
> daß es bei den Makros nicht angezeigt wird (ALT+F8)
kommentiere die Zeile
'Option Private Module
aus - Hochkomma am Zeilenanfang, der Code wird dann grün.
arno