Forum - Γενικά οριζοντια-καθετα

Forum (https://www.ms-office.gr/forum/)

- Excel - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/)

- - [Γενικά] οριζοντια-καθετα (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/346-orizontia-katheta.html)

οριζοντια-καθετα

καλημέρα σας, θα ήθελα παρακαλώ πολύ τη βοήθεια σας σχετικά με ένα πρόβλημα που με απασχολεί.
Σε ένα φύλλο excel έχω κάποια δεδομένα τα όποια είναι σε οριζόντια διάταξη.
Κενές γραμμές δεν υπάρχουν .
Πως θα μπορούσε να διαβάζει μια μια τη γραμμή και να μου δώσει τα αποτελέσματα σε κάθετη διάταξη.

Επισυνάπτω συνημμένο!

ΕΥΧΑΡΙΣΤΩ ΠΟΛΥ

Μαρια.

Παράθεση:

Αρχική Δημοσίευση από dimzoozoo (Μήνυμα 1280)

Γειά χαρά Μαρία.
Η λύση είναι στην αυτοματοποίηση. Αντίγραψε τον παρακάτω κώδικα και επικόλλησέ τον στον project explorer σου στο ανάλογο φύλλο. Τον εμφανίζεις με Alt+F11.
Προσοχή στο να αρχίζουν τα δεδομένα από το κελί Α1 και δεξιά από τα δεδομένα της πρώτης γραμμής και κάτω από αυτά της πρώτης στήλης να έχει κενά κελιά διότι θα αρχίσει να αντιγράφει ό,τι να 'ναι όπου να 'ναι. Είναι προγραμματισμένο να ξεκινά την επικόλληση αφήνοντας μια κενή στήλη δεξιά της στήλης που τελειώνουν τα δεδομένα.
Το πρόγραμμα δεν λειτουργεί σε εκδόσεις πριν τη 2007 διότι έχει hardcoded αριθμούς που αντιστοιχούν σε αυτήν την έκδοση.

Κώδικας:

Option Explicit
 

Sub Transposition()
 

Dim CountRows, CountCols, StartCoord, RowCounter
 

CountRows = Cells(1048576, 1).End(xlUp).Row

CountCols = Cells(1, 16384).End(xlToLeft).Column

StartCoord = CountCols + 2
 

For RowCounter = 1 To CountRows

    Range(Cells(RowCounter, 1), Cells(RowCounter, CountCols)).Copy

    Cells(1 + (RowCounter - 1) * CountCols, StartCoord).PasteSpecial Paste:=xlPasteAll, Operation:= _

    xlNone, SkipBlanks:= False, Transpose:=True

Next RowCounter
 

End Sub

Παιδιά εννοείται ότι εάν υπάρχει καλλίτερη, ταχύτερη, εξυπνότερη λύση την παραθέτουμε.

Αδάμ

σε ευχαριστω πολυ ΑΔΑΜ.δουλεψε μια χαρα .
να σαι καλα.

Γεια και χαρά σε όλους και όλες!

Παράθεση:

Αρχική Δημοσίευση από ShortCuter (Μήνυμα 1282)

Παιδιά εννοείται ότι εάν υπάρχει καλλίτερη, ταχύτερη, εξυπνότερη λύση την παραθέτουμε.

Μια ακόμη λύση θα ήταν η χρήση της λειτουργίας "Αντιγραφή-Ειδική επικόλληση"
με ενεργοποιημένο το "Αντιμετάθεση"(Transpose) ενώ με τον τρόπο της αυτοματοποίησης
και εφόσον δεν υπάρχουν κενές γραμμές στην "οριζόντια" περιοχή, θα μπορούσε να γίνει και έτσι:

Κώδικας:

Sub Transposition()

    With Range("A1").CurrentRegion

        .Copy

        .Offset(, .Columns.Count + 1).PasteSpecial , , , True

    End With

End Sub

Φίλε Αδάμ, χαίρομαι πολύ που ξαναβρεθήκαμε!:dft010:

Τα λέμε,
Γιάννης

Να 'σαι καλά φίλε nisgia. Θα τα λέμε από εδώ (στο μέτρο του δυνατού)!