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

[soctama]

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

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

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

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

[gr8styl]

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

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

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

[soctama]

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

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

[soctama]

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

:w orthy: