Inhalt von Spalten spiegel

Forumthread: Inhalt von Spalten spiegel

26.11.2005 06:37:09

Spalten

hallo, ich habe einen Datensatz und möchte diesen aufgrund von Symmetrieeigenschaften spiegeln.
Bsp:
123
456
789
101
das ist eine Spalte mit 4 Zahlen, diese soll gespiegelt werden zu:
101
789
456
123
so dass ich letztlich habe:
123
456
789
101
101
789
456
123
geht das irgendwie?
Vielen Dank
Oliver

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

AW: Inhalt von Spalten spiegel

26.11.2005 06:58:03

Spalten

AW: Inhalt von Spalten spiegel

26.11.2005 06:58:03

Spalten

Hallo Oliver,
versuch es mal damit:

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Public Sub prcTranspose_Reflect()
    Dim varArt As Variant
    Dim rngInputrange As Range, rngOutputrange As Range
    On Error Resume Next
    Set rngInputrange = Application.InputBox( _
        Prompt:="Eingabebereich mit der Maus markieren.", Title:="Auswahl", Type:=8)
    If Err.Number <> 0 Then Exit Sub
    Do
        Set rngOutputrange = Application.InputBox( _
            Prompt:="Oberste linke Zelle des Ausgabebereiches mit der Maus markieren.", _
            Title:="Auswahl", Type:=8)
        If Err.Number <> 0 Then Exit Sub
        If rngOutputrange.Cells.Count = 1 Then Exit Do
        MsgBox "Nur eine Zelle.", 48, "Hinweis"
    Loop
    On Error GoTo Err_Exit
    Do
        varArt = Application.InputBox(Prompt:="Art auswählen" & vbLf & vbLf & _
            "0 = Normales transponieren" & vbLf & _
            "1 = Zeilen und Spalten spiegeln" & vbLf & _
            "2 = Zeilen und Spalten spiegeln und transponieren", _
            Title:="Auswahl", Default:=0, Type:=1)
        If VarType(varArt) = vbBoolean And varArt = False Then Exit Sub
        If Fix(varArt) = varArt Then If varArt >= 0 And varArt <= 3 Then Exit Do
        MsgBox Prompt:="Nur die Zahlen 0 / 1 / 2 zulässig.", _
            Buttons:=vbExclamation, Title:="Hinweis"
    Loop
    Call Transpose_special(rngInputrange, rngOutputrange, Cbyte(varArt))
    Err_Exit:
End Sub

Private Sub Transpose_special(ByVal rngInputrange As Range, ByVal rngOutputrange As Range, _
        ByVal bytArt As Byte)
    Dim varArray() As Variant, lngRow As Long, intColumn As Integer
    On Error GoTo Err_Exit
    Select Case bytArt
        Case 0
            If rngOutputrange.Column + rngInputrange.Rows.Count - 1 <= 256 Then
                varArray = Application.WorksheetFunction.Transpose(rngInputrange)
                rngInputrange.Clear
                Range(rngOutputrange.Cells(1, 1), Cells(rngOutputrange.Row + _
                    rngInputrange.Columns.Count - 1, rngOutputrange.Column + _
                    rngInputrange.Rows.Count - 1)) = varArray
            Else
                Err.Raise Number:=vbObjectError + 1, Description:="Das passt nicht rein."
            End If
        Case 1
            If rngOutputrange.Row + rngInputrange.Rows.Count - 1 <= 256 Then
                Redim varArray(1 To rngInputrange.Rows.Count, 1 To rngInputrange.Columns.Count)
                For intColumn = 1 To rngInputrange.Columns.Count
                    For lngRow = 1 To rngInputrange.Rows.Count
                        varArray(lngRow, intColumn) = rngInputrange.Cells( _
                            rngInputrange.Rows.Count - lngRow + 1, _
                            rngInputrange.Columns.Count - intColumn + 1)
                    Next
                Next
                ' rngInputrange.Clear
                Range(rngOutputrange.Cells(1, 1), Cells(rngOutputrange.Row + _
                    rngInputrange.Rows.Count - 1, rngOutputrange.Column + _
                    rngInputrange.Columns.Count - 1)) = varArray
            Else
                Err.Raise Number:=vbObjectError + 2, Description:="Das passt nicht rein."
            End If
        Case 2
            If rngOutputrange.Column + rngInputrange.Rows.Count - 1 <= 256 Then
                Redim varArray(1 To rngInputrange.Columns.Count, 1 To rngInputrange.Rows.Count)
                For intColumn = 1 To rngInputrange.Columns.Count
                    For lngRow = 1 To rngInputrange.Rows.Count
                        varArray(intColumn, lngRow) = rngInputrange.Cells(rngInputrange.Rows.Count - _
                            lngRow + 1, rngInputrange.Columns.Count - intColumn + 1)
                    Next
                Next
                rngInputrange.Clear
                Range(rngOutputrange.Cells(1, 1), Cells(rngOutputrange.Row + _
                    rngInputrange.Columns.Count - 1, rngOutputrange.Column + _
                    rngInputrange.Rows.Count - 1)) = varArray
            Else
                Err.Raise Number:=vbObjectError + 3, Description:="Das passt nicht rein."
            End If
    End Select
    Exit Sub
    Err_Exit:
    MsgBox "Fehler " & CStr(Err.Number) & vbLf & vbLf & Err.Description, 16, "Fehler"
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

Forumthread: Inhalt von Spalten spiegel

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread