[VBA] VBA – Εκτέλεση κώδικα από το σημείο που βρίσκεται ο κέρσορας και κάτω

[devcon]

Καλημέρα και καλή εβδομάδα,

Θα ήθελα την βοήθεια σας

Θα ήθελα να μπορώ να πραγματοποιήσω τις ακόλουθες πράξεις από το σημείο που βρίσκεται ο κέρσορας και κάτω (μέχρι την τελευταία γραμμή όπου υπάρχουν προϊόντα) χωρίς να γίνονται οι πράξεις σε όλη την κολόνα.
Ο λόγος που δεν θέλω να γίνεται από την αρχή της κολόνας είναι ότι μπορώ χειροκίνητα να αλλάξω κάποιες τιμές (Unit price or Cost gross) και με αυτό τον τρόπο θα χάνω τις χειροκίνητες τιμές.
Τα προϊόντα ανανεώνονται συνεχώς αναλόγως της ζήτησης οπότε δεν είναι γνωστή η τελευταία γραμμή.
(Επισυνάπτω δείγμα spreadsheet και module για καλύτερη κατανόηση του προβλήματός μου).

Ευχαριστώ εκ των προτέρων.

' Locate the FinalRow
FinalRow = Cells(Rows.Count, 2).End(xlUp).row

' Cost Net
Range("K3:K" & FinalRow).Formula = "=IF(J3<>" & Chr(34) & Chr(34) & ",ROUND(J3*(1-($O$2%)),2)," & Chr(34) & Chr(34) & ")"

'   Unit Price
Range("I3:I" & FinalRow).Formula = "=IFERROR(ROUND(K3*(1+$N$2%),2), " & Chr(34) & Chr(34) & ")"

'Range("I3:I" & FinalRow).Formula = "=IF(H3<>" & Chr(34) & Chr(34) & ",ROUND(K3*(1+($N$2%)),2)," & Chr(34) & Chr(34) & ")"

' Total Cost
Range("L3:L" & FinalRow).Formula = "=IF(K3<>" & Chr(34) & Chr(34) & ",H3*K3," & Chr(34) & Chr(34) & ")"

' Total Sales
Range("M3:M" & FinalRow).Formula = "=IF(I3<>" & Chr(34) & Chr(34) & ",H3*I3," & Chr(34) & Chr(34) & ")"

[Tasos]

Καλημέρα Θανάση και καλωσόρισες στην παρέα μας!

Όρισε τα παρακάτω ονόματα στο φύλλο "Request For Quotations":

1. Owver: Αναφορά στο κελί $N$2
2. Supplier: Αναφορά στο κελί $O$2

Συμπλήρωσε τις τιμές στα παραπάνω κελιά και χρησιμοποίησε τον παρακάτω κώδικα (για Excel > 2003) :

Option Explicit

Sub Offer()
    Dim FirstRow As Long, FinalRow As Long, CalcRows As Long
    FirstRow = ActiveCell.Row
    FinalRow = Cells(Rows.Count, 2).End(xlUp).Row
    CalcRows = FinalRow - FirstRow + 1
    If Not IsNumeric(Range("Owners")) Or IsEmpty(Range("Owners")) _
       Or Not IsNumeric(Range("Supplier")) Or IsEmpty(Range("Supplier")) Then
        ' Code will exit. Show some message...
        Exit Sub
    End If
    If CalcRows < 1 Then
        'Can not be a valid Range... Show some message...
    End If

    Application.ScreenUpdating = False
    ' Cost Net
    With Range("K" & FirstRow & ":K" & FinalRow)
        .FormulaR1C1 = "=IF(RC[-1]<>"""",ROUND(RC[-1]*(1-Supplier%),2),"""")"
        .Value = .Value    'Convert Formulas to Values
    End With
    '   Unit Price

    With Range("I" & FirstRow & ":I" & FinalRow)
        .FormulaR1C1 = "=IFERROR(ROUND(RC[2]*(1+Owners%),2), """")"
        .Value = .Value
    End With

    ' Total Cost
    With Range("L" & FirstRow & ":L" & FinalRow)
        .FormulaR1C1 = "=IF(RC[-1]<>"""",RC[-4]*RC[-1],"""")"
        .Value = .Value
    End With

    ' Total Sales
    With Range("M" & FirstRow & ":M" & FinalRow)
        .FormulaR1C1 = "=IF(RC[-4]<>"""",RC[-5]*RC[-4],"""")"
        .Value = .Value
    End With

    ' Enter the Total Row
    FirstRow = FinalRow - 2

    Range("K3").Copy
    With Range("K" & FinalRow + 1).Resize(4, 3)
        .PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
        .Font.Bold = True
        .Font.Italic = True
        With .Resize(1, 3)

            '____________________________________Sum from selected Row________________________________

            '.Item(1).Value = "Total"
            '.Item(2).FormulaR1C1 = "=SUM(R[-" & CalcRows & "]C:R[-1]C)"
            '.Item(3).Formula = "=SUM(R[-" & CalcRows & "]C:R[-1]C)"
            '.Font.ColorIndex = xlAutomatic
            'With .Offset(1).Resize(3, 3)
                '.Item(1).Value = "Profit"
                '.Item(3).FormulaR1C1 = "=SUM(R[-" & CalcRows + 1 & "]C:R[-2]C)- SUM(R[-" & CalcRows + 1 & _
                                       "]C[-1]:R[-2]C[-1])"
                '.Item(4).Value = "P/C"
                '.Item(6).FormulaR1C1 = "=(SUM(R[-" & CalcRows + 2 & "]C:R[-3]C)- SUM(R[-" & CalcRows + 2 & _
                                       "]C[-1]:R[-3]C[-1]))/(SUM(R[-" & CalcRows + 2 & "]C[-1]:R[-3]C[-1]))"
                '.Item(6).NumberFormat = "0.00%"
                '.Item(7).Value = "P/S"
                '.Item(9).FormulaR1C1 = "=(SUM(R[-" & CalcRows + 3 & "]C:R[-4]C)- SUM(R[-" & CalcRows + 3 & _
                                       "]C[-1]:R[-4]C[-1]))/(SUM(R[-" & CalcRows + 3 & "]C:R[-4]C))"
                '.Item(9).NumberFormat = "0.00%"
                '.Font.ColorIndex = 41&
           ' End With
            '.Value = .Value    'Convert Formulas to Values

            '____________________________________Sum from the first Row__________________________________________

            .Item(1).Value = "Total"
            .Item(2).FormulaR1C1 = "=SUM(R[-" & FirstRow & "]C:R[-1]C)"
            .Item(3).Formula = "=SUM(R[-" & FirstRow & "]C:R[-1]C)"
            .Font.ColorIndex = xlAutomatic
            With .Offset(1).Resize(3, 3)
                .Item(1).Value = "Profit"
                .Item(3).FormulaR1C1 = "=SUM(R[-" & FirstRow + 1 & "]C:R[-2]C)- SUM(R[-" & FirstRow + 1 & _
                                       "]C[-1]:R[-2]C[-1])"
                .Item(4).Value = "P/C"
                .Item(6).FormulaR1C1 = "=(SUM(R[-" & FirstRow + 2 & "]C:R[-3]C)- SUM(R[-" & FirstRow + 2 & _
                                       "]C[-1]:R[-3]C[-1]))/(SUM(R[-" & FirstRow + 2 & "]C[-1]:R[-3]C[-1]))"
                .Item(6).NumberFormat = "0.00%"
                .Item(7).Value = "P/S"
                .Item(9).FormulaR1C1 = "=(SUM(R[-" & FirstRow + 3 & "]C:R[-4]C)- SUM(R[-" & FirstRow + 3 & _
                                       "]C[-1]:R[-4]C[-1]))/(SUM(R[-" & FirstRow + 3 & "]C:R[-4]C))"
                .Item(9).NumberFormat = "0.00%"
                .Font.ColorIndex = 41&
            End With
            '.Value = .Value 'Convert Formulas to Values

            '____________________________________________________________________________________________________
            
        End With
    End With
    Application.ScreenUpdating = True
End Sub

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

Φιλικά

Τάσος

[devcon]

Ευχαριστώ για την άμεση απάντησή σου.
Θα κάνω τις αλλαγές και θα επανέλθω.

[devcon]

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

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

Option Explicit

Sub Offer()
    Dim FirstRow As Long, FinalRow As Long
    FirstRow = ActiveCell.Row
    FinalRow = Cells(Rows.Count, 2).End(xlUp).Row
    If FirstRow < 2 Or FirstRow >= FinalRow Then
        'Can not be a valid Range... Show some message...
    End If
    Application.ScreenUpdating = False
    ' Cost Net
    With Range("K" & FirstRow & ":K" & FinalRow)
  .Formula = "=IF(J3<>"""",ROUND(J3*(1-Supplier%),2),"""")"

Από αυτό το σημείο δημιουργείτε πρόβλημα διότι οι πράξεις πρέπει να γίνονται από το σημείο
που είναι ο κέρσορας και κάτω και όχι από την αρχή (J3, K3, etc).
 
       

 .Value = .Value 'Convert Formulas to Values
    End With
    '   Unit Price

    With Range("I" & FirstRow & ":I" & FinalRow)
        .Formula = "=IFERROR(ROUND(K3*(1+Owners%),2), """")"
        .Value = .Value
    End With

    With Range("I" & FirstRow & ":I" & FinalRow)
        .Formula = "=IF(H3<>"""",ROUND(K3*(1+(Owners%)),2),"""")"
        .Value = .Value
    End With

    ' Total Cost
    With Range("L" & FirstRow & ":L" & FinalRow)
        .Formula = "=IF(K3<>"""",H3*K3,"""")"
        .Value = .Value
    End With

    ' Total Sales
    With Range("M" & FirstRow & ":M" & FinalRow)
        .Formula = "=IF(I3<>"""",H3*I3,"""")"
        .Value = .Value
    End With

    ' Enter the Total Row
    Range("K3").Copy
    With Range("K" & FinalRow + 1).Resize(4, 3)
        .PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
        .Font.Bold = True
        .Font.Italic = True
        With .Resize(1, 3)
            .Item(1).Value = "Total"
            .Item(2).Formula = "=SUM(L3:L" & FinalRow & ")"
            .Item(3).Formula = "=SUM(M3:M" & FinalRow & ")"
            .Font.ColorIndex = xlAutomatic
            With .Offset(1).Resize(3, 3)
                .Item(1).Value = "Profit"
                .Item(3).Formula = "=SUM(M3:M" & FinalRow & ")- SUM(L3:L" & FinalRow & ")"
                .Item(4).Value = "P/C"
                .Item(6).Formula = "=(SUM(M3:M" & FinalRow & ")- SUM(L3:L" & FinalRow & "))/(SUM(L3:L" & FinalRow & "))"
                .Item(6).NumberFormat = "0.00%"
                .Item(7).Value = "P/S"
                .Item(9).Formula = "=(SUM(M3:M" & FinalRow & ")- SUM(L3:L" & FinalRow & "))/(SUM(M3:M" & FinalRow & "))"
                .Item(9).NumberFormat = "0.00%"
                .Font.ColorIndex = 41&
            End With
            '.Value = .Value 'Convert Formulas to Values
        End With
    End With
    Application.ScreenUpdating = True
End Sub

[Tasos]

Καλησπέρα Θανάση!
....Ο δαίμονας του τυπογραφείου θα έλεγε κανείς..

Εγώ λέω "ο δαίμονας του Copy- Paste"

Έκανα λάθος και δημοσίευσα έναν ημιτελή κώδικα.

Δες λοιπόν στο προηγούμενο μου μήνυμα τον κώδικα στην τελική του μορφή.
Το μόνο που δε γνωρίσω είναι αν τα αποτελέσματα στις 3 τελευταίες γραμμές των συνόλων
αφορούν όλες τις γραμμές ή μόνο τις γραμμές από την επιλεγμένη και κάτω.
Και οι 2 περιπτώσεις περιλαμβάνονται στον κώδικα.

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

[gr8styl]

Καλησπέρα σας κύριοι.
( Άλλος Θανάσης εγώ ελπίζω να μην τα μπλέξουμε.)

Μήπως θα ήταν απλούστερο να γράψουμε απλά όλους του τύπους στην δεύτερη γραμμή και αντί της With Range("K"... End With στον κώδικα να χρησιμοποιήσουμε

Range("K2").Copy Destination:=Range("K" & FirstRow & ":K" & FinalRow)

Νομίζω ότι είναι πιο απλό από το να προσπαθούμε να γράψουμε στην VBA τις φόρμουλες σε R1C1 μορφή.

Ελπίζω να έχω καταλάβει το ζητούμενο και να μην κάνω λάθος.

Θανάσης Σ.

[Tasos]

Καλησπέρα Θανάσηδες!

Η Excel υπολογίζει πάντα σε R1C1.

Όταν η Excel "βλέπει" τύπους με κανονική μορφή (A1) θα πρέπει πρώτα να τους μετατρέψει σε R1C1 για να κάνει τον υπολογιστικό κύκλο.

Έτσι οι τύποι που χρησιμοποιούνται με μορφή R1C1 (Cell.FormulaR1C1), απαιτούν λιγότερο
χρόνο εκτέλεσης αφού δεν θα χρειαστεί να γίνει μετατροπή .
Βεβαίως δεν προγραμματίζει κανείς μας πια με τύπους R1C1 αφού όπως πολύ καλά ανέφερες δεν είναι και τόσο φιλικοί προς το χρήστη.

Στη VBA όμως, όταν αυτό επιβάλλεται, εγώ τουλάχιστον χρησιμοποιώ R1C1 (δεν έχω τις καλύτερες εμπειρίες σχετικά με τους τύπους στη VBA )

Η αλήθεια είναι ότι η προσέγγιση με την καταχώρηση τύπων προγραμματιστικά δεν με
ενθουσιάζει ιδιαίτερα αφού σχεδόν πάντα υπάρχουν εναλλακτικές λύσεις με χρήση
ενσωματωμένων συναρτήσεων της Excel που ειδικά στις νεώτερες εκδόσεις Excel είναι ταχύτατες.

Πέραν από τον τον τρόπο που παρουσιάζει ο Θανάσης (devcon) μέσα από το ερώτημα του
(που οφείλω να το σεβαστώ) εγώ θα χρησιμοποιούσα συναρτήσεις XL4 και σε συνδυασμό με
ελάχιστο κώδικα θα έφτανα στο επιθυμητό αποτέλεσμα.

Δείτε ένα παράδειγμα στο συνημμένο παρακάτω (για Excel > 2003).

Φιλικά

Τάσος

[devcon]

Τάσο καλημέρα,

Σε ευχαριστώ πολύ για την άψογη και τεκμηριωμένη βοήθεια σου ‘ΣΥΓΧΑΡΗΤΗΡΙΑ’.

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

Σε ευχαριστώ για μια ακόμη φορά για την άριστη βοήθεια.

Σου εύχομαι καλημέρα και καλή δουλειά.

Θανάσης (devcon)

[devcon]

Αρχική Δημοσίευση από Tasos

Καλησπέρα Θανάση!
....Ο δαίμονας του τυπογραφείου θα έλεγε κανείς..

Εγώ λέω "ο δαίμονας του Copy- Paste"

Έκανα λάθος και δημοσίευσα έναν ημιτελή κώδικα.

Δες λοιπόν στο προηγούμενο μου μήνυμα τον κώδικα στην τελική του μορφή.
Το μόνο που δε γνωρίσω είναι αν τα αποτελέσματα στις 3 τελευταίες γραμμές των συνόλων
αφορούν όλες τις γραμμές ή μόνο τις γραμμές από την επιλεγμένη και κάτω.
Και οι 2 περιπτώσεις περιλαμβάνονται στον κώδικα.

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

Αγαπητέ Τάσο,

Εχθές βρέθηκα μπροστά στο ακόλουθο πρόβλημα.
Σε κάποια κελιά (Unit price column “I”) χρειάσθηκε να βάλω χειροκίνητα τις τιμές και μετά έδωσα την μακρο-εντολή για να συμπλήρωση όλα τα υπόλοιπα κελιά και να κάνει τις πράξεις. Δυστυχώς η μακρο-εντολή μου ακύρωσε τις τιμές που είχα τοποθετήσει χειροκίνητα.

Σε παρακαλώ θα ήθελα να με βοηθήσεις οι πράξεις να γίνονται ως αναφέρεις ανωτέρω με την διαφορά ότι όταν βρίσκει ένα κελί με νούμερο να το μεταπηδά (skip cells) και να συνεχίζει στα υπόλοιπα κενά κελιά.

Ελπίζω να σου έδωσα να καταλάβεις το πρόβλημά μου.

Σε ευχαριστώ εκ των προτέρων για την βοήθεια σου.
Θανάσης (devcon)

[Tasos]

Καλημέρα Θανάση!

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

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

Απενεργοποιείς λοιπόν όλα τα " .Value = .Value " για να μπορέσει η Εφαρμογή να εντοπίσει τις σταθερές που έχεις πληκτρολογήσει (πάνω στους τύπους!!) και να τις υπερπηδήσει.
Παράλληλα, θα χρειαστούν αρκετές τροποποιήσεις στον κώδικα.

Όμως:
Ας πούμε ότι το κάνεις αυτό μια δυο φορές χρησιμοποιώντας έναν τροποποιημένο κώδικα.

1. Δεν θα είναι ξεκάθαρο σε ποια κελιά έχει επέμβει ο χρήστης.
Θα πρέπει να είσαι σε θέση να διακρίνεις που έχεις κάνει αλλαγές!.
Πως θα διακρίνεις τις δικές σου αλλαγές αφού δε διαφέρουν οπτικά από τους τύπους;

2. Επαναφορά τύπων
Τι θα κάνεις αν μετά από κάποιες πληκτρολογήσεις θελήσεις οι σταθερές αυτές να ξαναπάρουν την αρχική τους μορφή (τύπους);

Θα μπορούσες φυσικά να χρησιμοποιήσεις και τον αρχικό κώδικα (αυτόν που χρησιμοποιήσεις τώρα αφαιρώντας όμως τα " .Value = .Value ")
για επαναφέρεις όλους τους τύπους.

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

Παράδειγμα:

• Η στήλη "I" ("Unit Price" ) περιέχει τους τύπους.
• Η στήλη "J" που θα προσθέσεις ( θα γίνει στήλη "J" ) θα είναι κενή, ίσως με διαφορετικό χρώμα γραμματοσειράς για να ξεχωρίζει.

Ο τύπος στη στήλη "I" θα είναι:

=IF(J10<>"";J10;IFERROR(ROUND(L10*(1+Owners%);2); "")) όπου IFERROR(ROUND(L10*(1+Owners%);2); "") = ο αρχικός τύπος.

Μ αυτό τον τρόπο, πληκτρολογείς στην κενή στηλη ( "J" ) και η τιμή εμφανίζεται αυτόματα στη στήλη "I" ("Unit Price" ).

Νομίζω ότι έτσι το ελέγχεις καλύτερα.

Αν παρόλα αυτά νομίζεις ότι η VBA είναι απαραίτητη (κάνεις κατάχρηση της VBA )
τότε να σε βοηθήσουμε να μετατρέψεις τον κώδικα.

Με εκτίμηση


Τάσος