Microsoft Excel

Herbers Excel/VBA-Archiv

Daten in mehrern Abbeitsblättern transponieren

Betrifft: Daten in mehrern Abbeitsblättern transponieren von: Lemmi
Geschrieben am: 04.09.2014 08:10:13

Hallo zusammen,

ich möchte mit einem Makro Daten in mehreren Arbeitsblättern transponiren.
Die Daten liegen zur Zeit immer in A1 bis X100 in gleicher Art und Weise vor.

Zur Zeit bearbeitet ich die Daten wie folgt:
Ich makiere die Daten und kopiere die Daten über Inhalte einfügen transponieren wieder an anderer Stelle des jeweiligen Arbeitsblatt wieder ein.
Die Ursprungsdaten lösche ich, um dann die transponierten Daten nach A 1 und folgende zu verschieben.
Dies wiederhole ich für jedes Arbeisblatt.

Dies würde ich gerne in einem Marko mit allen Arbeitsblätten durchführen.

Gruß
Lemmi

  

Betrifft: AW: Daten in mehrern Abbeitsblättern transponieren von: Martin
Geschrieben am: 04.09.2014 10:08:49

Hallo Lemmi,

und so sieht das Makro aus:

Sub Makro1()
    Dim objWsh As Worksheet, varInhalt As Variant
    
    For Each objWsh In ActiveWorkbook.Sheets
        With objWsh
            varInhalt = Application.Transpose(.Range("A1:X100").Value)
            .Cells.Clear
            .Range("A1").Resize(UBound(varInhalt, 1), UBound(varInhalt, 2)) = varInhalt
        End With
    Next
End Sub
Viele Grüße

Martin


  

Betrifft: Vorschlag: WorkSheets statt Sheets ... von: Matthias L
Geschrieben am: 04.09.2014 10:28:51

Hallo


    Vorschlag: WorkSheets statt Sheets,
    sonst kommt bei einem evtl. vorhandenen Diagramm o.A eine Fehlermeldung!

  • Bei Sheets durchläuft die Schleife alle Blätter

  • Bei WorkSheets eben nur WorkSheets


Gruß Matthias


  

Betrifft: ...überredet ;-) von: Martin
Geschrieben am: 04.09.2014 10:36:19

Also nimm lieber folgendes Makro:

Sub Makro1()
    Dim objWsh As Worksheet, varInhalt As Variant
    
    For Each objWsh In ActiveWorkbook.Worksheets
        With objWsh
            varInhalt = Application.Transpose(.Range("A1:X100").Value)
            .Cells.Clear
            .Range("A1").Resize(UBound(varInhalt, 1), UBound(varInhalt, 2)) = varInhalt
        End With
    Next
End Sub
Viele Grüße

Martin


  

Betrifft: AW: ...überredet ;-) von: Lemmi
Geschrieben am: 04.09.2014 13:04:35

Hallo Ihr beiden,

vielen Dank für Eure Lösung! Es funktioniert soweit alles!

Allerdings habe ich bei der Listung feststellen müssen, dass die erste Spalte nicht immer gefüllt ist.
Deshalb müsste das Marko noch ergänzt werden.
Währe es also möglich, das zunächst geprüft werden kann ob Zellen in Spalte A leer ist. Ist eine Zelle in Spalte A leer so soll der Eintrag "Name fehlt" eingebracht werden.

Es soll nur soweit die Spalte A mit "Name fehlt" gefüllt werden, soweit in den Spalten B-X Inhalte vorhanden sind.


Vielen Dank schon einmal im Vorraus!

Gruß
Lemmi


  

Betrifft: SpecialCells(xlCellTypeBlanks) ... von: Matthias L
Geschrieben am: 04.09.2014 13:42:16

Hallo

With Range("A1:A100").SpecialCells(xlCellTypeBlanks)
.Value = "Name fehlt"
End With
Gruß Matthias


  

Betrifft: AW: SpecialCells(xlCellTypeBlanks) ... von: Martin
Geschrieben am: 04.09.2014 15:35:31

Hallo Lemmi,

ich war unterwegs und antworte deshalb erst jetzt. Ich fahre gleich noch 400 Kilometer Auto und kann deshalb nur noch bis 16 Uhr antworten. Der Vorschlag von Matthias klappt ist zwar grundsätzlich richtig, aber dann MUSS es leere Zellen geben in Spalte A geben (...dann kommt eine Fehlermeldung).
Hier mein Vorschlag:

Sub Makro1()
    Dim objWsh As Worksheet, varInhalt As Variant
    
    For Each objWsh In ActiveWorkbook.Worksheets
        With objWsh
            With .Range("A1:A100").SpecialCells(xlCellTypeBlanks)
                If .Count > 0 Then .Value = "Name fehlt"
            End With
            varInhalt = Application.Transpose(.Range("A1:X100").Value)
            .Cells.Clear
            .Range("A1").Resize(UBound(varInhalt, 1), UBound(varInhalt, 2)) = varInhalt
        End With
    Next
End Sub
Viele Grüße

Martin


  

Betrifft: AW: SpecialCells(xlCellTypeBlanks) ... von: Martin
Geschrieben am: 04.09.2014 15:35:37

Hallo Lemmi,

ich war unterwegs und antworte deshalb erst jetzt. Ich fahre gleich noch 400 Kilometer Auto und kann deshalb nur noch bis 16 Uhr antworten. Der Vorschlag von Matthias klappt ist zwar grundsätzlich richtig, aber dann MUSS es leere Zellen geben in Spalte A geben (...dann kommt eine Fehlermeldung).
Hier mein Vorschlag:

Sub Makro1()
    Dim objWsh As Worksheet, varInhalt As Variant
    
    For Each objWsh In ActiveWorkbook.Worksheets
        With objWsh
            With .Range("A1:A100").SpecialCells(xlCellTypeBlanks)
                If .Count > 0 Then .Value = "Name fehlt"
            End With
            varInhalt = Application.Transpose(.Range("A1:X100").Value)
            .Cells.Clear
            .Range("A1").Resize(UBound(varInhalt, 1), UBound(varInhalt, 2)) = varInhalt
        End With
    Next
End Sub
Viele Grüße

Martin


  

Betrifft: AW: SpecialCells(xlCellTypeBlanks) ... von: Lemmi
Geschrieben am: 04.09.2014 15:46:02

Hallo Matthias,

wie binde ich diesen Teil ein?

Gruß
Lemmi


  

Betrifft: AW: SpecialCells(xlCellTypeBlanks) ... von: Martin
Geschrieben am: 04.09.2014 15:49:59

Hallo Lemmi,

das habe ich dir doch gerade "optimiert" geschrieben?!

Viele Grüße

Martin


  

Betrifft: AW: SpecialCells(xlCellTypeBlanks) ... von: Lemmi
Geschrieben am: 04.09.2014 16:06:50

Hallo Martin,
sorry hatte ich nicht gesehen!


Danke! Danke!

Gruß
Lemmi


  

Betrifft: da wir gerade beim Optimieren waren ... von: Matthias L
Geschrieben am: 04.09.2014 17:01:54

Hallo

Da wir gerade dabei waren uns gegeseitig zu ergänzen :-)

Folgendes:
Bitte erstelle ein leeres Worksheet und positioniere es als letztes Tabellenblatt(WorkSheet).

Und nun bitte den Code laufen lassen.
Hier sollte also auch noch eine Überprüfung rein!

Gruß Matthias