ComputerBase Menü
Aktuelles

Excel - VBA transponiert kopieren mit Bedingung

E

Excelmania

Lieutenant
Registriert
Apr. 2010
Beiträge
797
Hallo.

Ich habe eine Excel-Arbeitsmappe mit zwei Tabellenblättern erstellt.

Auf dem Tabellenblatt "Fragebogen" erfolgen die Fragen in vertikaler Ausrichtung, sodass auch eine Erfassung auf Papier mit nachträglicher Übertragung möglich ist.

Aufbau:
Spalte A: Nr. (1. bis 35)
Spalte B: Frage
Spalte C: Antwort

Zur Besseren Gliederung gibt es Abschnittsüberschriften.

Auf dem Tabellenblatt "Datensätze" wiederum möchte ich die erfassten Daten in horizontal erfassen.

Jede Frage stellt somit ein Attribut (Spaltenüberschrift) dar.

Ich würde gerne mittels eines Makros die erhaltenen Antworten stets als neuen Datensatz vom Tabellenblatt "Fragebogen" auf das Tabellenblatt "Datensätze" kopieren und somit transponieren.

Bisher habe ich folgenden Code:

Code: 
Sub Datensatz_anlegen()

Dim lngLetzteZeile As Long
Dim lngAbZeile As Long
Dim lngZeile As Long
Dim wksQ As Worksheet
Dim wksZ As Worksheet

Set wksQ = Worksheets("Fragenbogen")
Set wksZ = Worksheets("Datensätze")
 
lngLetzteZeile = wksQ.Cells(wksQ.Rows.Count, 2).End(xlUp).Row

For lngZeile = lngAbZeile To lngLetzteZeile
        If wksQ.Range("B" & lngZeile).Value = wksZ.Range("H3").Value Then

    'Abschnitt 1
        wksZ.Range("A" & lngZeile).Value = wksQ.Range("C3").Value
        wksQ.Range("B" & lngZeile).Value = wksZ.Range("C4").Value
        wksQ.Range("C" & lngZeile).Value = wksZ.Range("C5").Value
        wksQ.Range("D" & lngZeile).Value = wksZ.Range("C6").Value
    'Abschnitt 2
        wksQ.Range("E" & lngZeile).Value  = wksZ.Range("C9").Value
        wksQ.Range("F" & lngZeile).Value  = wksZ.Range("C10").Value
        wksQ.Range("G" & lngZeile).Value = wksZ.Range("C11").Value
    'Abschnitt 3
…
        End If
    Next

End Sub

Nachteil dieser Variante ist jedoch, kommen noch Fragen hinzu oder werden Fragen nicht mehr erforderlich, muss ich immer den Code anpassen.
Mir schebt daher vor, über die ausgeblende Spalte "D" zu kennzeichen, dass die Antwort in C transponiert kopiert wird nach "D".
So brauche ich nur die Frage an der Richtigen Stelle hinzufügen. Fragen die entfallen, muss ich natürlich nur ausblenden, damit eine Eindeutigkeit erhalten bleibt.

Kann mir jemand beim Umbau dieses Codes helfen?

Vielen Dank.
 

Anhänge

Zuletzt bearbeitet:
Kann dein VBA-Script irgendwie erkennen, wann ein neuer Abschnitt beginnt? Denn das müsstest du irgendwie möglich machen.

C3-C6 wird ja nach A-D gemappt, C9-C11 nach E-G... also C7 und C8 gar nicht. Ich nehme an, Abschnitt 3 wäre dann von C14 beginnen und eben von H aus...
Kann das irgendwie erkannt werden? Weil dann würdest du eine Schleife machen können..

Und sicher, dass die Zeile hier korrekt ist?
Code: 
wksZ.Range("A" & lngZeile).Value = wksQ.Range("C3").Value
Müsste wksZ und wksQ nicht getauscht sein?

Was bedeutet
Code: 
If wksQ.Range("B" & lngZeile).Value = wksZ.Range("H3").Value Then

Evtl wäre ein Beispiel-Excel ganz praktisch.
 
Hi,
bitte eine bsp. Datei hochladen
 
Zuletzt bearbeitet:
  • Gefällt mir
Reaktionen: tollertyp
Hi,

ich habe gerade in einem ganz anderen Zusammenhang die Funktion Indirekt() in Excel kennengelernt, weil es auch darum ging, aus verschiedenen Tabellenblättern Informationen in transponierter Form zu übertragen.

Ist es nicht auch für Dein Problem denkbar, die Indirekt() Funktion anzuwenden... es kann sein, dass dann immer noch ein Makro nötig ist, aber vielleicht in weniger komplexer Form...dazu folgende Überlegungen:

- in der Tabelle "Datensätze" werden in einer der oberen Zeilen in der Spalte die Zeilennummer der jeweiligen Frage aus dem Tabellenblatt "Fragebogen" genannt.

- das Tabellenblatt "Datensätze" würde dann
in Zeile 1 die Frage enthalten
in Zeile 2 die Zeilennummer der Frage auf Tabellenblatt Fragebogen
in Zeile 3 die folgende Formel enthalten (am Beispiel Spalte A)

Also Inhalt Zelle A3 auf Tabellenblatt Datensätze

=indirekt("Fragebogen!A"&A2)

- Damit die Werte in Zeile 3 nicht beim nächsten Ausfüllen des Fragebogens überschrieben werden, müsste man Zeile 3 als Werte in die nächste freie Zeile bei den Datensätzen kopieren. Das kann man händisch oder per Makro machen. Sollten Fragen hinzukommen oder ausgeblendet werden, stellt es eigentlich kein Problem dar, denn per hand oder Makro markiert man einfach bis XlToEnd (also "STRG+SHIFT+CursorRechts").

- schwierig würde es werden, wenn neue Fragen auf der Tabelle "Fragebogen" an die gleiche Stelle kommen, wo vorher andere Fragen waren...dann gerät alles etwas durcheinander.

Vielleicht funktioniert dies auch nicht so wie Du möchtest, dann betrachte es lediglich als Denkanstoss.

Viel Erfolg
 
Hi,
meinst du das so ?
Code: 
Sub PasteTranspose()
Dim wksQ As Worksheet
Dim wksZ As Worksheet
Dim lngSpalte As Long
Dim lngZeile As Long

Set wksQ = Worksheets("Fragenbogen")
Set wksZ = Worksheets("Datensätze")

    With wksQ
        
        lngSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column
        lngZeile = .Cells(Rows.Count, 1).End(xlUp).Row
        
        .Range(.Cells(1, 1), .Cells(lngZeile, lngSpalte)).Copy
        
        wksZ.Range("A1").PasteSpecial Transpose:=True
        
    End With

End Sub
 
Guten Morgen.

Vielen Dank für die Ansätze. Leider klappt es noch nicht.

Ich habe versucht die Bedingungen einzubauen:

Code: 
Sub PasteTranspose()

Dim wksQ As Worksheet
Dim wksZ As Worksheet
Dim lngSpalte As Long
Dim lngZeile As Long
Dim i As Double

    v = 5
    b = 9

Set wksQ = Worksheets("Fragebogen")
Set wksZ = Worksheets("Datensätze")

'Datensätze: letzter Datensatz
e = Worksheets("Datensätze").UsedRange.SpecialCells(xlCellTypeLastCell).Row

    For i = v To b
        If Cells(i, 5) = "x" Then

        With wksQ
       
        lngSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column
        lngZeile = .Cells(Rows.Count, 1).End(xlUp).Row
       
        .Range(.Cells(1, 3), .Cells(lngZeile, lngSpalte)).Copy
       
        wksZ.Range("A" & (e + 1)).PasteSpecial Transpose:=True
       
        End With

        End If
    Next i

End Sub

Er kopiert jedoch nicht nur die gekennzeichneten Felder.
Ergänzung ()

Code: 
Sub PasteTranspose_2()

Dim wksQ As Worksheet
Dim wksZ As Worksheet
Dim lngSpalte As Long
Dim lngZeile As Long
Dim i As Double

    v = 5
    b = 9

Set wksQ = Worksheets("Fragebogen")
Set wksZ = Worksheets("Datensätze")

'Datensätze: letzter Datensatz
e = Worksheets("Datensätze").UsedRange.SpecialCells(xlCellTypeLastCell).Row

    For lngZeile = v To b
        If wksQ.Range("E" & lngZeile).Value = x Then

        wksZ.Range("A" & (e + 1)).PasteSpecial Transpose:=True = wksQ.Range("C" & lngZeile & ":D" & lngZeile).Value

        End If
    Next


End Sub

funktioniert leider auch nicht :(
 

Anhänge

Zuletzt bearbeitet:
Aus meiner Sicht: Wie denn auch?

Du prüfst ob "If Cells(i, 5) = "x" Then" aber auf die Zeile i nimmst du danach nirgends mehr Bezug...

Edit:
Ich würde in diese Richtung gehen:
Code: 
Sub PasteTranspose()

Dim wksQ As Worksheet
Dim wksZ As Worksheet
Dim currentColumn As Long
Dim i As Double

    v = 5
    b = 9

Set wksQ = Worksheets("Fragebogen")
Set wksZ = Worksheets("Tabelle1")

'Datensätze: letzter Datensatz
e = Worksheets("Datensätze").UsedRange.SpecialCells(xlCellTypeLastCell).Row

currentColumn = 1

    For i = v To b
        If Cells(i, 5) = "x" Then

        With wksQ
       
        lngSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column
        lngZeile = .Cells(Rows.Count, 1).End(xlUp).Row
       
        .Range(.Cells(i, 3), .Cells(i, 5)).Copy
       
        wksZ.Cells(1, currentColumn).PasteSpecial Transpose:=True
        currentColumn = currentColumn + 1
       
        End With

        End If
    Next i

End Sub
Aber vielleicht verstehe ich es auch immer noch nicht

Das kommt da raus:
1604995733985.png

Die Überschriften müsstest du ja getrennt noch machen...
 

Anhänge

  • 1604995716279.png
    1604995716279.png
    2,5 KB · Aufrufe: 285
Zuletzt bearbeitet:
Hi.

Vielen Dank für den Ansatz. Der bringt mich schon ein bischen weiter.
Schaubild.jpg


So als ob fest definiert wäre:

Code: 
    'Abschnitt 1
        wksZ.Range("A" & LZ).Value = wksQ.Range("C5").Value
        wksZ.Range("B" & LZ).Value = wksZ.Range("D5").Value
        wksZ.Range("C" & LZ).Value = wksZ.Range("C6").Value
        wksZ.Range("D" & LZ).Value = wksZ.Range("D6").Value
    'Abschnitt 2
        wksZ.Range("E" & LZ).Value = wksZ.Range("C8").Value
        wksZ.Range("F" & LZ).Value = wksZ.Range("D8").Value
        wksZ.Range("G" & LZ).Value = wksZ.Range("C9").Value
        wksZ.Range("H" & LZ).Value = wksZ.Range("D9").Value
Ergänzung ()

Excelmania schrieb:
Hi.

Vielen Dank für den Ansatz. Der bringt mich schon ein bisschen weiter.
Schaubild.jpg


So als ob fest definiert wäre:

Code: 
    'Abschnitt 1
        wksZ.Range("A" & LZ).Value = wksQ.Range("C5").Value
        wksZ.Range("B" & LZ).Value = wksZ.Range("D5").Value
        wksZ.Range("C" & LZ).Value = wksZ.Range("C6").Value
        wksZ.Range("D" & LZ).Value = wksZ.Range("D6").Value
    'Abschnitt 2
        wksZ.Range("E" & LZ).Value = wksZ.Range("C8").Value
        wksZ.Range("F" & LZ).Value = wksZ.Range("D8").Value
        wksZ.Range("G" & LZ).Value = wksZ.Range("C9").Value
        wksZ.Range("H" & LZ).Value = wksZ.Range("D9").Value
Zum Vergrößern anklicken....
 
Hi,
wo soll ich nur Anfangen.

Du muss Prüfen auf letzte Zeile im Worksheet Datensätze (bzw. da wo die Auswertung hin soll) damit du die Werte untereinander oder neben einander einfügen kannst (je nachdem wie man es gern hat).

Zweitens so wird das nix, weil du Frage 1.1/1.2 hast und dann 2.1/2.2 und alles per x in Spalte E gekennzeichnet ist, aber woher soll jetzt die Schleife wissen wohin was eingefügt werden soll?? und was ist jetzt was??
Ergo man muss auch noch die Frage (1.1/1.2/2.1/2.2) Abfragen sprich Spalte B neben der Spalte E die x abfragt.

Hier ein Bsp. für Frage 1.1/1.2
Code: 
Sub PasteTranspose()
Dim wksQ As Worksheet
Dim wksZ As Worksheet
Dim lngSpalte As Long
Dim lngZeile As Long
Dim i As Integer
Dim lngZeileInWksZ As Long

Set wksQ = Worksheets("Fragebogen")
Set wksZ = Worksheets("Datensätze")

    'letzte Zeile in wksZ auslesen
    lngZeileInWksZ = wksZ.Cells(Rows.Count, 1).End(xlUp).Row + 1

    'Schleife läuft von 5 bis 7
    For i = 5 To 7
        
        'Abfrage Zeile i in Spalte E nach x und wenn passt dann
        If Cells(i, 5).Value = "x" Then
            
            'Bereich Zeile i und Spalte C & D kopieren
            wksQ.Range(Cells(i, 3), Cells(i, 4)).Copy
            
            'einfügen in Zeile (letzteZeile sheet Datensätze) Spalte 1
            wksZ.Cells(lngZeileInWksZ, 1).PasteSpecial Paste:=xlValue
            
            'Kopier Methode aus
            Application.CutCopyMode = False
            
        End If
        
        'letzte Zeile + 1
        lngZeileInWksZ = lngZeileInWksZ + 1
    
    Next i

End Sub
Ich habe jetzt die Abfrage in Spalte B nach Frage nicht dazu geschrieben, das kannst du selber machen, dann muss du noch die letzte Zeile im Zeil Worksheet herausfinden und die richtige Spalte angeben ;-)

Das hat wie du siehst nichts mit .PasteSpecial Transpose:=True zutun, wenn man ein Bereich von A nach B kopiert bzw. einfügt!

Frage, wieso nutzt du nicht die Filter Möglichkeit?
 
Moin,

das Ganze ist ziemlich instabil und wird, wenn du es nicht nur selbst benutzt, zu Problemen führen :-).

Tu dir einen Gefallen und schreibe dir eine extra Funktion für das Einfügen in deine "Datenbank". Das ist ansich kein großes Problem, allerdings benutzt du zusammengesetzte Zellen in Zeile 1 und damit hat VBA ein paar Schwierigkeiten.

Ich gebe dir hier mal einen Prototypen dieser Funktion, dann kannst du ja mal schauen was du daraus machst.

Code: 
Public Function getDataset(ByVal frage As String) As Range

Dim i As Integer

i = 1

With ThisWorkbook.Worksheets("Datensätze")

    Do
       
        If StrComp(.Cells(1, i).Value, frage, vbTextCompare) = 0 Then
       
            Set getDataset = Range(.Cells(1, i).Offset(2, 0), .Cells(1, i).Offset(2, 1).Offset(2, -1))
       
        End If
       
        i = i + 2
   
    Loop Until .Cells(1, i).Value = vbNullString


End With

End Function

Diese Funktion liefert dir die Range zurück welche sich in der Datenbank unter der im Funktionskopf eingegebenen Frage befindet. Dann kannst du da ganz einfach per cells(1,1) und cells(1,2) deine Daten reinschreiben und sie sind automatisch am richtigen Ort.

Wie gesagt, musste hier ein bisschen tricksen, wegen den zusammengefassten Zellen, deswegen i = i + 2. Man könnte das jetzt noch umgehen, wenn man used range benutzt, oder so. Aber das hier soll ja auch nur einen Lösungsansatz liefern :-)

Edit:

Hier nochmal komplett und in schön. Meine erste Lösung hat mir nicht so gut gefallen :-)

Jetzt sollten keine Fragen mehr offen sein...haha

Code: 
Option Explicit

Sub PasteTranspose()

Dim i         As Integer
Dim datenSatz As Range

With Worksheets("Fragebogen")
    
    'Datensätze: letzter Datensatz nur Spalte 5
    For i = 4 To .Cells(.Rows.Count, 5).End(xlUp).Row
    
        If StrComp(.Cells(i, 5).Value, "x", vbTextCompare) = 0 Then
            
            'Aufruf der Funktion mit der entsprechenden Frage
            Set datenSatz = getDatensatz(.Cells(i, 2).Value)
            
            'Zurück kommt eine Referenz auf die Range in Zeile drei
            'im sheet Datensätze. Diese kann man direkt beschreiben
            
            'Wenn nicht nichts gefunden wurde -> schreibe die Values
            If Not datenSatz Is Nothing Then
                
                datenSatz.Cells(1, 1).Value = .Cells(i, 3).Value
                datenSatz.Cells(1, 2).Value = .Cells(i, 4).Value
                
                'Löschen des Zeigers nur um sicher zu gehen
                Set datenSatz = Nothing
                
            End If

        End If
        
    Next i
        
End With

End Sub


Public Function getDatensatz(ByVal frage As String) As Range

Dim i As Integer

With ThisWorkbook.Worksheets("Datensätze")

    For i = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
        
        If StrComp(.Cells(1, i).Value, frage, vbTextCompare) = 0 Then
        
            Set getDatensatz = Range(.Cells(1, i).Offset(2, 0), .Cells(1, i).Offset(2, 0).Offset(0, 1))
            Exit For
            
        End If
    
    Next i

End With

End Function
 
Zuletzt bearbeitet:
Hallo Janush,

vielen Dank für den Lösungsansatz. Perfekt, dass er das zweite Tabellenblatt anspricht und auch in einer Zeile. Leider überschreibt er jedoch immer den ersten Datensatz und sobald ich weitere Fragen/Antworten aufnehmen (x) dann er diese nicht mit.
 

Anhänge

Was meinst Du?

Du musst natürlich genau sein mit dem Kopf deiner "Datenbank". Das meine ich mit instabil. Irgendwelche Abweichungen und bumm. Den Primärschlüssel darf es natürlich nur einmal geben :-)

1605190345190.png


Was meinst du mit neuen Fragen aufnehmen? Willst du das diese automatisch hinten angehängt werden? Dann muss da natürlich eine kleine Erweiterung in die GetDatensatz Funktion.
 
Moin Janush.

Perfekt. Du bist der Beste!

Das Problem mit dem Schreiben am Ende habe ich jetzt einfach dadurch gelöst, dass am Anfang erst eine Leere Zeile erzeugt wird:

Code: 
Option Explicit

Sub PasteTranspose()

Dim i         As Integer
Dim datenSatz As Range

Worksheets("Datensätze").Rows(3).Insert
Worksheets("Datensätze").Rows(3).Interior.ColorIndex = 0
Worksheets("Datensätze").Rows(3).Font.ColorIndex = 1

With Worksheets("Fragebogen")
    
    'Datensätze: letzter Datensatz nur Spalte 5
    For i = 5 To .Cells(.Rows.Count, 5).End(xlUp).Row
    
        If StrComp(.Cells(i, 5).Value, "x", vbTextCompare) = 0 Then
            
            'Aufruf der Funktion mit der entsprechenden Frage
            Set datenSatz = getDatensatz(.Cells(i, 2).Value)
            
            'Zurück kommt eine Referenz auf die Range in Zeile drei
            'im sheet Datensätze. Diese kann man direkt beschreiben
            
            'Wenn nicht nichts gefunden wurde -> schreibe die Values
            If Not datenSatz Is Nothing Then
                
                datenSatz.Cells(1, 1).Value = .Cells(i, 3).Value
                datenSatz.Cells(1, 2).Value = .Cells(i, 4).Value
                
                'Löschen des Zeigers nur um sicher zu gehen
                Set datenSatz = Nothing
                
            End If

        End If
        
    Next i
        
End With

End Sub


Public Function getDatensatz(ByVal frage As String) As Range

Dim i As Integer

With ThisWorkbook.Worksheets("Datensätze")

    For i = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
        
        If StrComp(.Cells(1, i).Value, frage, vbTextCompare) = 0 Then
        
            Set getDatensatz = Range(.Cells(1, i).Offset(2, 0), .Cells(1, i).Offset(2, 0).Offset(0, 1))
            Exit For
            
        End If
    
    Next i

End With

End Function
 
Du musst dich einloggen oder registrieren, um hier zu antworten.

Ähnliche Themen

duAffentier
Excel VBA - Termin in Outlook - manuell Speichern
Antworten
1
Aufrufe
1.501
duAffentier
duAffentier
T
Excel VBA String Zusammenstellung
Antworten
8
Aufrufe
2.185
DukNukem
DukNukem
E
[EXCEL-VBA] Speichern mit Pfadauswahl als xlsm
Antworten
1
Aufrufe
4.676
spcqike
S
E
Excel VBA kopieren mit Transponieren
Antworten
4
Aufrufe
1.638
cumulonimbus8
cumulonimbus8
Nightfly09
Excel VBA Makro zu langsam
Antworten
9
Aufrufe
9.919
Scientist
S
Zurück
Oben

Willkommen auf ComputerBase!

Mit Werbung weiterlesen

Besuche ComputerBase wie gewohnt mit Werbung und Tracking. Die Zustimmung ist jederzeit widerrufbar.

Details im Privacy Center und in der Liste unserer Partner. Ein Widerruf ist möglich in der Datenschutzerklärung.

… oder ComputerBase Pro bestellen

Nutze ComputerBase ohne Werbebanner, Video-Ads und Werbetracking schon für 4 €/Monat oder 36 €/Jahr.

Mehr zu ComputerBase Pro

Bereits Pro-Nutzer? Hier anmelden.

Tracking: Wir und unsere 160 Partner verarbeiten personenbezogene Daten, indem wir mit auf Ihrem Gerät gespeicherten Informationen (z. B. eindeutige Kennungen in Cookies) ein Nutzungsprofil erstellen, um z. B. Anzeigen zu personalisieren. Verarbeitungszwecke: Genaue Standortdaten und Abfrage von Geräteeigenschaften zur Identifikation, Informationen auf einem Gerät speichern und/oder abrufen, Personalisierte Anzeigen und Inhalte, Anzeigen- und Inhaltsmessungen, Erkenntnisse über Zielgruppen und Produktentwicklungen.

Impressum Kontakt Datenschutz