'entwickelt von Winfried Radner
'e-mail: Wolf.W.Radzinski@onlinehome.de
'Benutzung frei - ohne Gewähr


'verbundene Funktionen
Sub flip_180()
  flip_it_ud
  flip_it_lr
End Sub
Sub flip_180_f()
  flip_it_ud_f
  flip_it_lr_f
End Sub
Sub flip_180_s()
  flip_it_ud_s
  flip_it_lr_s
End Sub
Sub flip_180_f_s()
  flip_it_ud_f_s
  flip_it_lr_f_s
End Sub


'die folgenden Funktionen beachten UsedRange
'und beschneiden die Selektion passend



Sub flip_it_ud()
On Error GoTo was_war_das
'spiegelt den selektierten Datenbereich
'von unten nach oben

   'ich lege ein temporäres Worksheet an
   Dim sh, old As Worksheet
     a = Worksheets.Count
     Set old = ActiveSheet
     Cursor = xlWait
   Application.ScreenUpdating = False
   'wenn aktive Zelle nicht im benutzen Bereich,
   'dann korrigiere aktive Zellposition
   'wenn hoehe und breite größer usedrange
   'korrigiere dies ebenfalls
   
     r = Selection.Row
     c = Selection.Column
     min_r = ActiveSheet.UsedRange.Row
     min_c = ActiveSheet.UsedRange.Column
     max_r = ActiveSheet.UsedRange.Rows.Count + min_r - 1
     max_c = ActiveSheet.UsedRange.Columns.Count + min_c - 1
     h = 0: b = 0
     If r < min_r Then h = min_r - r: r = min_r
     If r > max_r Then h = r - max_r: r = max_r
     If c < min_c Then b = min_c - c: c = min_c
     If c > max_c Then b = c - max_c: c = max_c
     hoehe = Selection.Rows.Count - h
     breite = Selection.Columns.Count - b
     
     If r = max_r Then r = max_r - hoehe + 1
     If c = max_c Then c = max_c - breite + 1
     
     If r + hoehe - 1 > max_r Then hoehe = max_r - r + 1
     If c + breite - 1 > max_c Then breite = max_c - c + 1
     mitte = hoehe \ 2

     max_c = ActiveSheet.UsedRange.Columns.Count
     If breite > max_c Then breite = max_c
     mitte = hoehe \ 2
   
   'erzeuge das temp. Worksheet
     Set sh = Worksheets.Add(, Worksheets(a))
   'gehe zurück zum alten WS
     old.Activate
   'Beginne den Austausch
     For ci = 0 To breite - 1
       For ri = 0 To mitte - 1
          sh.Cells(1, 1) = Cells(r + ri, c + ci)
          Cells(r + ri, c + ci) = Cells(r + hoehe - ri - 1, c + ci)
          Cells(r + hoehe - ri - 1, c + ci) = sh.Cells(1, 1)
       Next ri
     Next ci
   'lösche das temporäre WS ohne Sicherheitsabfrage
     Application.DisplayAlerts = False
     sh.Delete
     Application.DisplayAlerts = True
was_war_das:
     Application.ScreenUpdating = True
     Cursor = xlDefault
End Sub


Sub flip_it_lr()
On Error GoTo was_war_das
'spiegelt den selektierten Datenbereich
'von links nach rechts

   Dim sh, old As Worksheet
     a = Worksheets.Count
     Set old = ActiveSheet
     Cursor = xlWait
   Application.ScreenUpdating = False
   
     r = Selection.Row
     c = Selection.Column
     min_r = ActiveSheet.UsedRange.Row
     min_c = ActiveSheet.UsedRange.Column
     max_r = ActiveSheet.UsedRange.Rows.Count + min_r - 1
     max_c = ActiveSheet.UsedRange.Columns.Count + min_c - 1
     h = 0: b = 0
     If r < min_r Then h = min_r - r: r = min_r
     If r > max_r Then h = r - max_r: r = max_r
     If c < min_c Then b = min_c - c: c = min_c
     If c > max_c Then b = c - max_c: c = max_c
     hoehe = Selection.Rows.Count - h
     breite = Selection.Columns.Count - b
     
     If r = max_r Then r = max_r - hoehe + 1
     If c = max_c Then c = max_c - breite + 1
     
     If r + hoehe - 1 > max_r Then hoehe = max_r - r + 1
     If c + breite - 1 > max_c Then breite = max_c - c + 1
     mitte = breite \ 2
     
     Set sh = Worksheets.Add(, Worksheets(a))
     old.Activate
     For ri = 0 To hoehe - 1
       For ci = 0 To mitte - 1
          sh.Cells(1, 1) = Cells(r + ri, c + ci)
          Cells(r + ri, c + ci) = Cells(r + ri, c + breite - 1 - ci)
          Cells(r + ri, c + breite - 1 - ci) = sh.Cells(1, 1)
       Next ci
     Next ri
     Application.DisplayAlerts = False
     sh.Delete
     Application.DisplayAlerts = True
was_war_das:
     Application.ScreenUpdating = True
     Cursor = xlDefault
End Sub

' die Folgenden Funktionen kopieren auch DM % Uhrzeit Datumfelder
' und zeigen sie in der gespiegelten Zelle WIE VORHER an
' damit muß nicht der gesamte Bereich identisches Format aufweisen
' dies wäre sowieso meist äußerst unrealistisch

Sub flip_it_ud_f()
On Error GoTo was_war_das
'spiegelt den selektierten Datenbereich
'INKL ALLER FORMATE von unten nach oben

   'ich lege ein temporäres Worksheet an
   Dim sh, old As Worksheet
     a = Worksheets.Count
     Set old = ActiveSheet
     Cursor = xlWait
   Application.ScreenUpdating = False
   
   'wenn aktive Zelle nicht im benutzen Bereich,
   'dann korrigiere aktive Zellposition
   'wenn hoehe und breite größer usedrange
   'korrigiere dies ebenfalls
     CutCopyMode = xlAll
     r = Selection.Row
     c = Selection.Column
     min_r = ActiveSheet.UsedRange.Row
     min_c = ActiveSheet.UsedRange.Column
     max_r = ActiveSheet.UsedRange.Rows.Count + min_r - 1
     max_c = ActiveSheet.UsedRange.Columns.Count + min_c - 1
     h = 0: b = 0
     If r < min_r Then h = min_r - r: r = min_r
     If r > max_r Then h = r - max_r: r = max_r
     If c < min_c Then b = min_c - c: c = min_c
     If c > max_c Then b = c - max_c: c = max_c
     hoehe = Selection.Rows.Count - h
     breite = Selection.Columns.Count - b
     
     If r = max_r Then r = max_r - hoehe + 1
     If c = max_c Then c = max_c - breite + 1
     
     If r + hoehe - 1 > max_r Then hoehe = max_r - r + 1
     If c + breite - 1 > max_c Then breite = max_c - c + 1
     mitte = hoehe \ 2
   
   'erzeuge das temp. Worksheet
     Set sh = Worksheets.Add(, Worksheets(a))
   'gehe zurück zum alten WS
     old.Activate
   'Beginne den Zellaustausch inkl. Formaten
     For ci = 0 To breite - 1
       For ri = 0 To mitte - 1
          Cells(r + ri, c + ci).Copy (sh.Cells(1, 1))
          Cells(r + hoehe - ri - 1, c + ci).Copy (Cells(r + ri, c + ci))
          sh.Cells(1, 1).Copy (Cells(r + hoehe - ri - 1, c + ci))
       Next ri
     Next ci
   'lösche das temporäre WS ohne Sicherheitsabfrage
     sh.Activate
     Application.DisplayAlerts = False
     sh.Delete
     Application.DisplayAlerts = True
     old.Activate
was_war_das:
     Application.ScreenUpdating = True
     Cursor = xlDefault
End Sub


Sub flip_it_lr_f()
On Error GoTo was_war_das
'spiegelt den selektierten Datenbereich
'INKL ALLER FORMATE von links nach rechts

   Dim sh, old As Worksheet
     a = Worksheets.Count
     Set old = ActiveSheet
     Cursor = xlWait
   Application.ScreenUpdating = False
   
     r = Selection.Row
     c = Selection.Column
     min_r = ActiveSheet.UsedRange.Row
     min_c = ActiveSheet.UsedRange.Column
     max_r = ActiveSheet.UsedRange.Rows.Count + min_r - 1
     max_c = ActiveSheet.UsedRange.Columns.Count + min_c - 1
     h = 0: b = 0
     If r < min_r Then h = min_r - r: r = min_r
     If r > max_r Then h = r - max_r: r = max_r
     If c < min_c Then b = min_c - c: c = min_c
     If c > max_c Then b = c - max_c: c = max_c
     hoehe = Selection.Rows.Count - h
     breite = Selection.Columns.Count - b
     
     If r = max_r Then r = max_r - hoehe + 1
     If c = max_c Then c = max_c - breite + 1
     
     If r + hoehe - 1 > max_r Then hoehe = max_r - r + 1
     If c + breite - 1 > max_c Then breite = max_c - c + 1
     mitte = breite \ 2
     
     Set sh = Worksheets.Add(, Worksheets(a))
     old.Activate
     For ri = 0 To hoehe - 1
       For ci = 0 To mitte - 1
          Cells(r + ri, c + ci).Copy (sh.Cells(1, 1))
          Cells(r + ri, c + breite - 1 - ci).Copy (Cells(r + ri, c + ci))
          sh.Cells(1, 1).Copy (Cells(r + ri, c + breite - 1 - ci))
       Next ci
     Next ri
     sh.Activate
     Application.DisplayAlerts = False
     sh.Delete
     Application.DisplayAlerts = True
     old.Activate
was_war_das:
     Application.ScreenUpdating = True
     Cursor = xlDefault
End Sub



'die folgenden Funktionen beachten UsedRange NICHT,
'sondern richten sich einzig und allein nach
'Selektion



Sub flip_it_ud_s()
On Error GoTo was_war_das
'spiegelt den selektierten Datenbereich
'von unten nach oben

   'ich lege ein temporäres Worksheet an
   Dim sh, old As Worksheet
     a = Worksheets.Count
     Set old = ActiveSheet
     Cursor = xlWait
   Application.ScreenUpdating = False
   
     r = Selection.Row
     c = Selection.Column
     hoehe = Selection.Rows.Count
     breite = Selection.Columns.Count
     mitte = hoehe \ 2

     max_c = ActiveSheet.UsedRange.Columns.Count
     If breite > max_c Then breite = max_c
     mitte = hoehe \ 2
   
   'erzeuge das temp. Worksheet
     Set sh = Worksheets.Add(, Worksheets(a))
   'gehe zurück zum alten WS
     old.Activate
   'Beginne den Austausch
     For ci = 0 To breite - 1
       For ri = 0 To mitte - 1
          sh.Cells(1, 1) = Cells(r + ri, c + ci)
          Cells(r + ri, c + ci) = Cells(r + hoehe - ri - 1, c + ci)
          Cells(r + hoehe - ri - 1, c + ci) = sh.Cells(1, 1)
       Next ri
     Next ci
   'lösche das temporäre WS ohne Sicherheitsabfrage
     Application.DisplayAlerts = False
     sh.Delete
     Application.DisplayAlerts = True
was_war_das:
     Application.ScreenUpdating = True
     Cursor = xlDefault
End Sub


Sub flip_it_lr_s()
On Error GoTo was_war_das
'spiegelt den selektierten Datenbereich
'von links nach rechts

   Dim sh, old As Worksheet
     a = Worksheets.Count
     Set old = ActiveSheet
     Cursor = xlWait
   Application.ScreenUpdating = False
   
     r = Selection.Row
     c = Selection.Column
     hoehe = Selection.Rows.Count
     breite = Selection.Columns.Count
     mitte = breite \ 2
     
     Set sh = Worksheets.Add(, Worksheets(a))
     old.Activate
     For ri = 0 To hoehe - 1
       For ci = 0 To mitte - 1
          sh.Cells(1, 1) = Cells(r + ri, c + ci)
          Cells(r + ri, c + ci) = Cells(r + ri, c + breite - 1 - ci)
          Cells(r + ri, c + breite - 1 - ci) = sh.Cells(1, 1)
       Next ci
     Next ri
     Application.DisplayAlerts = False
     sh.Delete
     Application.DisplayAlerts = True
was_war_das:
     Application.ScreenUpdating = True
     Cursor = xlDefault
End Sub

' die Folgenden Funktionen kopieren auch DM % Uhrzeit Datumfelder
' und zeigen sie in der gespiegelten Zelle WIE VORHER an
' damit muß nicht der gesamte Bereich identisches Format aufweisen
' dies wäre sowieso meist äußerst unrealistisch

Sub flip_it_ud_f_s()
On Error GoTo was_war_das
'spiegelt den selektierten Datenbereich
'INKL ALLER FORMATE von unten nach oben

   'ich lege ein temporäres Worksheet an
   Dim sh, old As Worksheet
     a = Worksheets.Count
     Set old = ActiveSheet
     Cursor = xlWait
   Application.ScreenUpdating = False
   
     CutCopyMode = xlAll
     r = Selection.Row
     c = Selection.Column
     hoehe = Selection.Rows.Count
     breite = Selection.Columns.Count
     mitte = hoehe \ 2
   
   'erzeuge das temp. Worksheet
     Set sh = Worksheets.Add(, Worksheets(a))
   'gehe zurück zum alten WS
     old.Activate
   'Beginne den Zellaustausch inkl. Formaten
     For ci = 0 To breite - 1
       For ri = 0 To mitte - 1
          Cells(r + ri, c + ci).Copy (sh.Cells(1, 1))
          Cells(r + hoehe - ri - 1, c + ci).Copy (Cells(r + ri, c + ci))
          sh.Cells(1, 1).Copy (Cells(r + hoehe - ri - 1, c + ci))
       Next ri
     Next ci
   'lösche das temporäre WS ohne Sicherheitsabfrage
     sh.Activate
     Application.DisplayAlerts = False
     sh.Delete
     Application.DisplayAlerts = True
     old.Activate
was_war_das:
     Application.ScreenUpdating = True
     Cursor = xlDefault
End Sub


Sub flip_it_lr_f_s()
On Error GoTo was_war_das
'spiegelt den selektierten Datenbereich
'INKL ALLER FORMATE von links nach rechts

   Dim sh, old As Worksheet
     a = Worksheets.Count
     Set old = ActiveSheet
     Cursor = xlWait
   Application.ScreenUpdating = False
   
     r = Selection.Row
     c = Selection.Column
     hoehe = Selection.Rows.Count
     breite = Selection.Columns.Count
     mitte = breite \ 2
     
     Set sh = Worksheets.Add(, Worksheets(a))
     old.Activate
     For ri = 0 To hoehe - 1
       For ci = 0 To mitte - 1
          Cells(r + ri, c + ci).Copy (sh.Cells(1, 1))
          Cells(r + ri, c + breite - 1 - ci).Copy (Cells(r + ri, c + ci))
          sh.Cells(1, 1).Copy (Cells(r + ri, c + breite - 1 - ci))
       Next ci
     Next ri
     sh.Activate
     Application.DisplayAlerts = False
     sh.Delete
     Application.DisplayAlerts = True
     old.Activate
was_war_das:
     Application.ScreenUpdating = True
     Cursor = xlDefault
End Sub