Live-Forum - Die aktuellen Beiträge
Datum
Titel
20.04.2024 16:39:00
ältere VBA Codes automatisch neu strukturieren
20.04.2024 16:36:42
Arbeitsblatt Script auslagern in Modul
20.04.2024 16:28:25
zwei Makro in einem zusammenführen?
20.04.2024 15:30:14
Warum Verweis zeigt Falsch an
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1136to1140
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1136to1140
1136to1140
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Bereiche transponieren

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

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

Betreff
Benutzer
Anzeige
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

Anzeige
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

Anzeige
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

Anzeige
AW: Bereiche transponieren
08.02.2010 10:12:52
Peter
Hallo Sepp
Das war der Volltreffer!
Vielen Dank, Peter

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige