[Γενικά] Μετακίνηση εγγραφών

[ΔΗΜΗΤΡΙΟΣ]

Θα ήθελα αν γίνεται το επώνυμο -όνομα να ευθυγραμμιστεί με τους αριθμούς .

Αυτό να γίνει είτε με μετακίνηση του επώνυμου-ονόματος προς τα κάτω είτε μετακίνηση των αριθμων προς τα πάνω.

Επίσης η προηγούμενη σειρά να διαγραφεί και να μην έχω κενές γραμμές

Θα ήθελα αν γίνεται με vba και χωρίς vba.

Σας ευχαριστώ πολύ!

[kapetang]

Καλησπέρα

Δημήτρη, δες μια πρόταση στο συνημμένο.

[Spirosgr]

Καλησπέρα
Θεωρώ, ότι το ζητούμενο, είναι πιο απλό απ' ότι φαίνεται...

Αρκεί να διαγράψουμε την περιοχή κελιών:
d1:m1

Με ενεργό το φύλλο ΚΑΤΑΣΤΑΣΗ-1, τρέχουμε μια γραμμή κώδικα.

Sub Macro1()
    ActiveSheet.Range("d1:m1").Delete Shift:=xlUp
End Sub

Τώρα:
Αν θέλουμε να κλειδώσουμε τον κώδικα και να μην τρέξει ξανα αν
η πρώτη γραμμή είναι πλήρης, βάζουμε:

Sub Macro1()
If WorksheetFunction.CountA(Range("d1:m1")) = 0 Then _
    ActiveSheet.Range("d1:m1").Delete Shift:=xlUp
End Sub

Οι κενές γραμμές που υπάρχουν ανάμεσα στις εγγραφές,
μπορούν να φύγουν με τον ίδιο περίπου τρόπο.
Απλά πρέπει να ξεκινήσεις να διαγράφεις από κάτω προς τα πάνω...
Δοκίμασέ να το φτιάξεις μόνος σου με step - ... και αν δεν το καταφέρεις μιλάμε.

*Τα πιο πάνω ισχύουν για το συγκεκριμένο layout του παραδείγματος

[ΔΗΜΗΤΡΙΟΣ]

Καλημέρα σας .
Σας ευχαριστώ πολύ!

[Spirosgr]

Καλημέρα
Ο κώδικας ολοκληρωμένος, για όσους μας διαβάζουν κι έχουν παρόμοιο θέμα.

Τι κάνει
Αν στη γραμμή 1, το τμήμα d1:m1 είναι κενό, τότε:
1.Ευθυγραμμίζει τις εγγραφές
2.Διαγράφει τις ενδιάμεσες κενές γραμμές
3.Διορθώνει τον α/α

Sub FixData()
    If WorksheetFunction.CountA(Range("d1:m1")) = 0 Then
        ActiveSheet.Range("d1:m1").Delete Shift:=xlUp
    Else
        Exit Sub
    End If

    Dim lrow As Long, i As Long
    lrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

    Application.ScreenUpdating = False

    For i = lrow To 2 Step -2
        ActiveSheet.Rows(i).Delete Shift:=xlUp
        ActiveSheet.Cells(i - 1, 1).Value = (ActiveSheet.Cells(i - 1, 1).Value + 1) / 2
    Next i
End Sub

Προσαρμόστε ανάλογα, με τις ανάγκες σας για διαφορετικό layout...

Αν δεν θέλετε να εκτελείται στο ενεργό φύλλο, αλλά σε κάποιο άλλο,
αντικαταστήστε παντού, το ActiveSheet, με το κωδικό όνομα του φύλλου σας.

*Τα πιο πάνω ισχύουν για το συγκεκριμένο layout του παραδείγματος

[kapetang]

Καλημέρα

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

Συγκεκριμένα:

Η γραμμή κώδικα: lrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row, θα εντοπίσει τον αριθμό της γραμμής του τελευταίου ονόματος (ΧΑΤΖΗΚΩΝΣΤΑΝΤΗΣ).

Στη συνέχεια ο βρόχος: For i = lrow To 2 Step -2, αρχίζοντας από το τελευταίο όνομα και προχωρώντας προς τα πάνω, θα διαγράφει γραμμές με ονόματα και όχι κενές.

Προτείνω η σχετική γραμμή να γίνει:

lrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1

[Spirosgr]

Δεν υπάρχει κανένα λάθος!

Στο παράδειγμα, η τελευταία γραμμή (71) είναι όνομα,
χωρίς τους αριθμούς της από κάτω (72).
Αυτό προφανώς είναι τυχαίο, διότι ο Δημήτρης ανέβασε ένα τμήμα δεδομένων.

Το σωστό είναι, τα δεδομένα να έχουν στο τέλος την μορφή της εικόνας,
για να υπάρχει νόημα...

[ΔΗΜΗΤΡΙΟΣ]

Είσαστε πολύ καλοί και οι δύο.
Μας βοηθάτε πολύ.
Ευχαριστούμε!!

[Tasos]

Καλημέρα!

Για τη διαγραφή γραμμών με βάση τα κενά κελιά στη στήλη Β θα πρότεινα:

    With Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp)).Offset(, 1)
        If WorksheetFunction.CountBlank(.Cells) Then
            .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        End If
    End With

Καλή συνέχεια σε όλους!

Τάσος

[Tasos]

Δημήτρη εσύ θα μας πεις τι γίνεται με τους αριθμούς.

Κατά τη γνώμη μου στη στήλη Α πρόκειται για αρίθμηση γραμμών του και όχι εγγραφών.

Γενικότερα, ο α/α που διορθώνεται και διαφοροποιείται από τον αρχικό παύει να θεωρείται α/α.

Αν παρόλα αυτά χρειαστεί αρίθμηση εκ νέου τότε γράφουμε:

Sub test()
    If WorksheetFunction.CountA(Range("d1:m1")) = 0 Then
        ActiveSheet.Range("d1:m1").Delete Shift:=xlUp
        With Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp)).Offset(, 1)
            If WorksheetFunction.CountBlank(.Cells) Then
                .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
            End If
        End With
        Cells(1, 1).Value = 1
        Cells(1, 1).AutoFill Destination:=Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp)), Type:=xlFillSeries
    End If
End Sub

Edit: Ο κώδικας στο προηγούμενο μου μήνυμα είναι τμήμα της ρουτίνας που αναγράφεται παραπάνω.

Καλή συνέχεια!
Τάσος