[VBA] Ακέραιοι αριθμοί

[ΔΗΜΗΤΡΙΟΣ]

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

[Tasos]

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

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

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

Δε γνωρίζω τι θέλεις να επιτύχεις αλλά αν πρόκειται για μια απλή ταξινόμηση δεν θα χρειαστείς 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

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

[Spirosgr]

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

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 του πρωτότυπου (Α).

[ChrisGT7]

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

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

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

[ΔΗΜΗΤΡΙΟΣ]

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