Forum - Γενικά Μετατροπή κελιών στο Excel

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

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

- - [Γενικά] Μετατροπή κελιών στο Excel (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/1502-metatropi-kelion-sto-excel.html)

Μετατροπή κελιών στο Excel

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

Έχω ένα αρχείο excel το οποίο έχει πάρα πολλά sheets μεσα στην μορφή που θα δείτε στο αρχείο. Όλα τα sheets έχουν ακριβώς την ίδια μορφή και τα κελιά είναι ακριβώς ίδια ως προσ την στήλη και την γραμμή. Αλλάζουν μόνο τα περιεχόμενα. Εγώ θέλω λοιπόν να πάρω ένα κελί το H5 και να το βάλω σε ένα καινούριο sheet και κάθετα δίπλα του όλα τα κελιά που έχει στο sheet 02.02, δηλαδή από το Ι5 έως ΑΒ5. θα το δείτε τι εννοώ στο sheet1 που έχω το παράδειγμα.

Αυτό το κάνουμε για όλα τα κελιά στην στήλη H. Δηλαδή παίρνουμε όλα τα κελιά της στήλης H και τα βάζουμε κάθετα ανάλογα με το πόσα κελιά έχουν στις στήλες δίπλα τους. Εδώ έχω κάνει ένα μικρό παράδειγμα.
Αυτό θέλω να γίνετε αυτόματα για όλα τα κελιά και για όλα τα sheets.

Για οποιαδήποτε διευκρίνηση πείτε μου.. Και πάλι ευχαριστώ.

Καλημέρα καλησπέρα.
Φίλε Σωκράτη αν έχω καταλάβει σωστά το ζητούμενό σου,
ο παρακάτω κώδικας αντιγράφει τα στοιχεία από όλα τα φύλλα του βιβλίου στο φύλλο Sheet1.
Δοκίμασέ το και πες μας αν έγινε.
Ελπίζω να καταφέρεις να τον προσαρμόσεις παραπέρα αν χρειαστεί.

Φιλικά
Θανάσης :039:

Κώδικας:

Option Explicit
 

Sub test()

Dim DstSheet As String

Dim Sht As Worksheet

Dim R As Long, FirstRow As Long, LastRow As Long

Dim Answer
 

DstSheet = "Sheet1"
 

Answer = MsgBox("Do you want to clear " & DstSheet & " ?", vbYesNo)

If Answer = vbYes Then Sheets(DstSheet).Cells.Clear

Application.ScreenUpdating = False

For Each Sht In ThisWorkbook.Sheets

    If Sht.Name <> DstSheet Then

        LastRow = Sheets(DstSheet).Cells(Rows.Count, "A").End(xlUp).Row

        Sheets(DstSheet).Cells(LastRow + 1, "A").Value = "'" & Sht.Name

        Sht.Range("D5").Copy Destination:=Sheets(DstSheet).Cells(LastRow + 1, "B")

        

        For R = 5 To 27 'copy  each cell from range H5:H27 to dstSheet column C

            LastRow = Sheets(DstSheet).Cells(Rows.Count, "D").End(xlUp).Row

            If Sht.Range("H" & R).Value <> "" Then

                Sht.Cells(R, "H").Copy Destination:=Sheets(DstSheet).Cells(LastRow + 1, "C")

                Application.CutCopyMode = False

                Sht.Range("I" & R & ":AB" & R).Copy 'range I5:AB5 to dstSheet column D

                Sheets(DstSheet).Cells(LastRow + 1, "D").PasteSpecial Paste:=xlPasteAll, _

                        Operation:=xlNone, SkipBlanks:=False, Transpose:=True

                

                FirstRow = Sheets(DstSheet).Cells(Rows.Count, "C").End(xlUp).Row

                LastRow = Sheets(DstSheet).Cells(Rows.Count, "D").End(xlUp).Row

                Sheets(DstSheet).Cells(FirstRow, "C").Copy Destination:= _

                        Range("C" & FirstRow & ":C" & LastRow) 'fill down column C

            End If

        Next R

        FirstRow = Sheets(DstSheet).Cells(Rows.Count, "A").End(xlUp).Row

        LastRow = Sheets(DstSheet).Cells(Rows.Count, "D").End(xlUp).Row

        Sheets(DstSheet).Range("A" & FirstRow & ":B" & FirstRow).Copy Destination:= _

            Range("A" & FirstRow & ":B" & LastRow) 'fill down columns A and B

    End If

Next

Application.ScreenUpdating = True

Sheets(DstSheet).Activate

Sheets(DstSheet).Range("A1").Select

MsgBox "Data copied to " & DstSheet & " worksheet.", vbOKOnly

End Sub

ΣΕ ευχαριστώ για την απαντησή σου.. Μόλις το είδα αλλά πρέπει να φύγω για την δοθλειά και δεν έχω χρόνο να το τσεκάρω..Νομίζω λίγο που διάβασα τον κώδικα πως δουλεύει ρολόι... Θα σου πω όταν μπορέσω να το κοιτάξω καλύτερα. ΚΑι αν χρειαστώ βοήθεια θα σου πω....:worthy::worthy::worthy::worthy:

Και πάλι ευχαριστώ.

Το πόσα ευχαριστώ σου χρωστάω δεν λέγεται... Να είσαι καλά.. Δουλεύει τέλεια. Το παραμετροποίησα και λίγο και είναι μια χαρά!! Ελπίζω να μην χρειαστώ τίποτα άλλο πάνω σε αυτό! Και πάλι ευχαριστώ..

:worthy::worthy::worthy::worthy::worthy::worthy::w orthy::worthy::worthy: