Bereiche transponieren

Forumthread: Bereiche transponieren

Peter

Guten Abend
Ich habe in einer Datei ca. 20 Tabellen mit einer numerischen Bezeichnung (333666, 777111, etc.) nebst anderen Tabellen mit anderen alphanumerischen Bezeichnungen.
In jeder dieser Datei mit numerischer Bezeichnung ist der Bereich
A1:BQ8 mit Daten gefüllt.
Nun möchte ich alle in allen diesen TAbellen die Daten transponieren.
Nachher sollen diese Daten in A1:H69 stehen.
Wer kann mir weiterhelfen?
Danke, Peter

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

AW: Bereiche transponieren

06.02.2010 22:33:25

Josef

Hallo Peter,

probier mal.

' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub transposeRange()
  Dim objSh As Worksheet
  Dim vntRange As Variant

  For Each objSh In ThisWorkbook.Worksheets
    If IsNumeric(objSh.Name) Then
      vntRange = objSh.Range("A1:BQ8")
      objSh.Range("A1:BQ8") = ""
      vntRange = TransposeDim(vntRange)
      objSh.Range("A1").Resize(UBound(vntRange, 1), UBound(vntRange, 2)) = vntRange
      Erase vntRange
    End If
  Next

  Set objSh = Nothing
End Sub

Private Function TransposeDim(Field As Variant) As Variant
  Dim lngX1 As Long, lngY1 As Long, lngX2 As Long, lngY2 As Long
  Dim varTmp As Variant

  lngX1 = LBound(Field, 2)
  lngX2 = UBound(Field, 2)
  lngY1 = LBound(Field, 1)
  lngY2 = UBound(Field, 1)

  Redim varTmp(1 To lngX2, 1 To lngY2)

  For lngX1 = 1 To lngX2
    For lngY1 = 1 To lngY2
      varTmp(lngX1, lngY1) = Field(lngY1, lngX1)
    Next
  Next

  TransposeDim = varTmp

End Function

Gruß Sepp

AW: Bereiche transponieren

07.02.2010 18:12:43

Peter

Hallo Sepp
Das hat auf Anhieb geklappt. Vielen Dank!
Einzig die Formate der einzelnen Zellen ging verloren.
Muss man da damit leben, oder kann man die "irgendwie" auch noch mitnehmen?
Danke und Gruss, Peter

AW: Bereiche transponieren

07.02.2010 22:41:06

Josef

Hallo Peter,

sicher geht das, aber mit einem ganz anderen Ansatz.

Sub transposeRange()
  Dim objSh As Worksheet, objTmp As Worksheet
  On Error GoTo ErrExit
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set objTmp = ThisWorkbook.Worksheets.Add

  For Each objSh In ThisWorkbook.Worksheets
    If IsNumeric(objSh.Name) Then
      objSh.Range("A1:BQ8").Copy objTmp.Range("A1")
      objSh.Range("A1:BQ8").Clear
      objTmp.Range("A1").CurrentRegion.Copy
      objSh.Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=True
    End If
  Next

  ErrExit:
  If Not objTmp Is Nothing Then objTmp.Delete
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  Set objSh = Nothing
  Set objTmp = Nothing
End Sub

Gruß Sepp

AW: Bereiche transponieren

08.02.2010 09:24:34

Peter

Hallo Sepp
Danke für die Antwort.
Jetzt werden noch irgendwelche Daten unterschlagen, denn ich erhalte in nur die Daten, aus der Zeile 1 bis Spalte Q aus der Quell-Tabelle in den neuen Tabellen im Bereich A1:A17.
Vielleicht weil die Spalte R leer ist? Von den Zeilen 2 bis 8 landet gar nichts in den neuen Tabellen.
Leider verstehe ich von den Objekten zuwenig, dass ich das anpassen könnte (resp. mein pröbeln hat zu keiner Lösung geführt).
Darf ich nochmals um Hilfe bitten?
Herzlichen Dank, Peter

AW: Bereiche transponieren

08.02.2010 10:07:41

Josef

Hallo Peter,

dann probier es so.

Sub transposeRange()
  Dim objSh As Worksheet, objTmp As Worksheet
  On Error GoTo ErrExit
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Set objTmp = ThisWorkbook.Worksheets.Add

  For Each objSh In ThisWorkbook.Worksheets
    If IsNumeric(objSh.Name) Then
      objSh.Range("A1:BQ8").Copy objTmp.Range("A1")
      objSh.Range("A1:BQ8").Clear
      objTmp.Range("A1:BQ8").Copy
      objSh.Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=True
    End If
  Next

  ErrExit:
  If Not objTmp Is Nothing Then objTmp.Delete
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  Set objSh = Nothing
  Set objTmp = Nothing
End Sub

Gruß Sepp

AW: Bereiche transponieren

08.02.2010 10:12:52

Peter

Hallo Sepp
Das war der Volltreffer!
Vielen Dank, Peter

Beliebteste Forumthreads (12 Monate)

Forumthread: Bereiche transponieren

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread