Forum - VBA Ακέραιοι αριθμοί

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

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

- - [VBA] Ακέραιοι αριθμοί (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/5341-akeraioi-arithmoi.html)

Ακέραιοι αριθμοί

Μεταφορά των ακεραίων απο τη στήλη Α στη στήλη Β αλλά σε σειρά (χωρίς κενά κελιά).
Ευχαριστώ!

Δημήτρη καλησπέρα!

Τα δεδομένα έχουν κεφαλίδα;
Πρόκειται για αύξουσα ή φθίνουσα ταξινόμηση;
Πρόκειται να ταξινομηθεί ολόκληρη η στήλη ή μόνο τμήμα της;
Πρέπει να ταξινομηθούν τυχόν στήλες που υπάρχουν δίπλα στην στήλη προς ταξινόμηση;

Δώσε μας τα φώτα σου για να μπορέσουμε να σε βοηθήσουμε.

Δε γνωρίζω τι θέλεις να επιτύχεις αλλά αν πρόκειται για μια απλή ταξινόμηση δεν θα χρειαστείς VBA. Αρκεί το πάτημα ενός κουμπιού της εφαρμογής.
Αν χρησιμοποιήσεις VBA δεν θα έχεις πρόσβαση στο ιστορικό και δεν θα μπορέσεις να κάνεις κάποια αναίρεση αν χρειαστεί.

Με εκτίμηση

Τάσος

Ακέραιοι αριθμοί

Τάσο καλημέρα!
Το πρόβλημα το έχω λύσει με λίγες κινήσεις (Προφανώς είναι εύκολο)
έγραψα έναν κώδικα με το mod 1 δεν λειτουργεί Ο κώδικας είναι:
Sub Geor()
For i = 1 To 20
reg = Range("A" & i).Value
If reg Mod 1 = reg Then
k = k + 1
Range("B" & k).Value = Range("A" & i).Value
End If
Next i
End Sub

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

Για το ζητούμενο, ο πιο κάτω κώδικας είναι αρκετός.

Κώδικας:

Sub ExtractInts()

    Dim lrow        As Long

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

    Dim i           As Long

    Dim cellVal     As Double

    Dim intPart     As Long

    Dim k           As Long

    Application.ScreenUpdating = False

    ActiveSheet.Range("b1:b" & lrow).ClearContents
 

    For i = 1 To lrow

        cellVal = ActiveSheet.Range("a" & i).Value

        intPart = Int(cellVal)

        If intPart = cellVal Then

            k = k + 1

            ActiveSheet.Range("b" & k).NumberFormat = ActiveSheet.Range("a" & i).NumberFormat

            ActiveSheet.Range("b" & k).Value = ActiveSheet.Range("a" & i).Value

        End If

    Next i
 
 '    ActiveSheet.Sort.SortFields.Clear

'    ActiveSheet.Sort.SortFields.Add Key:=Range("b1"), _

'                                    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _

'                                    xlSortTextAsNumbers

'    With ActiveSheet.Sort

'        .SetRange Range("b1:b" & lrow)

'        .Header = xlNo

'        .MatchCase = False

'        .Orientation = xlTopToBottom

'        .SortMethod = xlPinYin

'        .Apply

'    End With

End Sub

Λειτουργεί, στο ενεργό φύλλο (ActiveSheet).
Γιά άλλο φύλλο, αντικαταστήστε με το κωδικό του όνομα.
Η ταξινόμηση (αύξουσα), είναι απενεργοποιημένη (ενεργοποιήστε αν χρειάζεται).
Για ταξινόμηση φθίνουσα, το κόκκινο να γίνει xlDescending.
Πριν ξεκινήσει, καθαρίζει την Β στήλη.
Η τελευταία γραμμή της Α, είναι πάντα μεγαλύτερη (το πολύ ίση) με της Β.
Για το λόγο αυτό, δεν χρειάζονται (στο ζητούμενο αυτό και μόνο), δύο μεταβλητές lrow.
Το NumberFormat του αριθμού που θα αντιγραφεί (Β),
είναι ίδιο με το NumberFormat του πρωτότυπου (Α).

Καλημέρα Δημήτρη,

Μια ακόμα πρόταση:

Κώδικας:

Option Explicit
 

Sub SortRange()

    Dim I As Long

    I = Range("A" & Rows.Count).End(xlUp).Row

    

    Range("B:B").ClearContents

    With Range("B1:B" & I)

        .Formula = "=IFERROR(IF(ISNUMBER(A1),IF(ISERROR(FIND("","",A1)),A1,""""),""""),"""")"

        .Value = .Value

        .Sort Key1:=[B1], Order1:=xlAscending, Header:=xlNo

    End With

End Sub

Ακέραιοι αριθμοί

Σπύρο και Χρήστο σας ευχαριστώ πολύ.
Να είσαστε καλά!