Note: The other languages of the website are Google-translated. Back to English

Πώς να μετακινήσετε ολόκληρη τη σειρά σε άλλο φύλλο με βάση την τιμή κελιού στο Excel;

Για να μετακινήσετε ολόκληρη τη σειρά σε άλλο φύλλο με βάση την τιμή κελιού, αυτό το άρθρο θα σας βοηθήσει.

Μετακίνηση ολόκληρης της σειράς σε άλλο φύλλο με βάση την τιμή κελιού με τον κώδικα VBA
Μετακίνηση ολόκληρης της σειράς σε άλλο φύλλο με βάση την τιμή κελιού με το Kutools για Excel


Μετακίνηση ολόκληρης της σειράς σε άλλο φύλλο με βάση την τιμή κελιού με τον κώδικα VBA

Όπως φαίνεται στο παρακάτω στιγμιότυπο οθόνης, πρέπει να μετακινήσετε ολόκληρη τη σειρά από το Sheet1 στο Sheet2 εάν υπάρχει μια συγκεκριμένη λέξη "Done" στη στήλη C. Μπορείτε να δοκιμάσετε τον ακόλουθο κώδικα VBA.

1. Τύπος άλλος+ F11 ταυτόχρονα για να ανοίξετε το Microsoft Visual Basic για εφαρμογές παράθυρο.

2. Στο παράθυρο της Microsoft Visual Basic for Applications, κάντε κλικ στο Κύριο θέμα > Μονάδα μέτρησης. Στη συνέχεια, αντιγράψτε και επικολλήστε τον παρακάτω κώδικα VBA στο παράθυρο.

VBA code 1: Move entire row to another sheet based on cell value

Sub Cheezy()
'Updated by Kutools for Excel 2017/8/28
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    I = Worksheets("Sheet1").UsedRange.Rows.Count
    J = Worksheets("Sheet2").UsedRange.Rows.Count
    If J = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Sheet1").Range("C1:C" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "Done" Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
            xRg(K).EntireRow.Delete
            If CStr(xRg(K).Value) = "Done" Then
                K = K - 1
            End If
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Note: Στον κώδικα, Sheet1 είναι το φύλλο εργασίας περιέχει τη σειρά που θέλετε να μετακινήσετε. Και Sheet2 είναι το φύλλο εργασίας προορισμού όπου θα βρείτε τη σειρά. «Γ: Γ"Είναι η στήλη περιέχει τη συγκεκριμένη τιμή και τη λέξη"Ολοκληρώθηκε"Είναι η συγκεκριμένη τιμή βάσει της οποίας θα μετακινήσετε τη σειρά. Αλλάξτε τα ανάλογα με τις ανάγκες σας.

3. Πάτα το F5 για να εκτελέσετε τον κωδικό, τότε η σειρά που πληροί τα κριτήρια στο Φύλλο1 θα μετακινηθεί αμέσως στο Φύλλο2

Note: Ο παραπάνω κώδικας VBA θα διαγράψει σειρές από τα αρχικά δεδομένα μετά τη μετάβαση σε ένα καθορισμένο φύλλο εργασίας. Εάν θέλετε να αντιγράψετε μόνο σειρές με βάση την τιμή κελιού αντί να τις διαγράψετε. Εφαρμόστε τον παρακάτω κωδικό VBA 2.

VBA code 2: Copy entire row to another sheet based on cell value

Sub MoveRowBasedOnCellValue()
'Updated by Extendoffice 2017/11/10
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    I = Worksheets("Sheet1").UsedRange.Rows.Count
    J = Worksheets("Sheet2").UsedRange.Rows.Count
    If J = 1 Then
    If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Sheet1").Range("C1:C" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "Done" Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Μετακίνηση ολόκληρης της σειράς σε άλλο φύλλο με βάση την τιμή κελιού με το Kutools για Excel

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

Πριν από την εφαρμογή Kutools για Excel, σας παρακαλούμε κατεβάστε και εγκαταστήστε το πρώτα.

1. Επιλέξτε τη λίστα στηλών που περιέχει την τιμή κελιού βάσει της οποίας θα μετακινήσετε σειρές και, στη συνέχεια, κάντε κλικ στο Kutools > Αγορά > Επιλέξτε συγκεκριμένα κελιά. Δείτε το στιγμιότυπο οθόνης:

2. Στο άνοιγμα Επιλέξτε συγκεκριμένα κελιά , επιλέξτε Ολόκληρη σειρά στο Τύπος επιλογής , επιλέξτε ισούται στο Ειδικός τύπος αναπτυσσόμενη λίστα, εισαγάγετε την τιμή κελιού στο πλαίσιο κειμένου και, στη συνέχεια, κάντε κλικ στο OK κουμπί.

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

3. Πάτα το Ctrl + C για να αντιγράψετε τις επιλεγμένες σειρές και, στη συνέχεια, να τις επικολλήσετε στο φύλλο εργασίας προορισμού που χρειάζεστε.

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

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


Σχετικά Άρθρα:


Τα καλύτερα εργαλεία παραγωγικότητας του Office

Το Kutools για Excel λύνει τα περισσότερα από τα προβλήματά σας και αυξάνει την παραγωγικότητά σας κατά 80%

  • Επαναχρησιμοποίηση: Εισαγάγετε γρήγορα σύνθετοι τύποι, γραφήματα και οτιδήποτε έχετε χρησιμοποιήσει στο παρελθόν. Κρυπτογράφηση κυττάρων με κωδικό πρόσβασης Δημιουργία λίστας αλληλογραφίας και στείλτε email ...
  • Super Formula Bar (επεξεργαστείτε εύκολα πολλές γραμμές κειμένου και τύπου). Διάταξη ανάγνωσης (εύκολη ανάγνωση και επεξεργασία μεγάλου αριθμού κελιών). Επικόλληση σε φιλτραρισμένο εύρος...
  • Συγχώνευση κελιών / σειρών / στηλών χωρίς απώλεια δεδομένων · Περιεχόμενο διαχωρισμού κελιών Συνδυάστε διπλές σειρές / στήλες... Αποτροπή διπλών κυττάρων; Συγκρίνετε τα εύρη...
  • Επιλέξτε Διπλότυπο ή Μοναδικό Σειρές; Επιλέξτε Κενές σειρές (όλα τα κελιά είναι κενά). Σούπερ εύρεση και ασαφής εύρεση σε πολλά βιβλία εργασίας. Τυχαία επιλογή ...
  • Ακριβές αντίγραφο Πολλαπλά κελιά χωρίς αλλαγή της αναφοράς τύπου. Αυτόματη δημιουργία αναφορών σε πολλαπλά φύλλα? Εισαγωγή κουκκίδων, Πλαίσια ελέγχου και άλλα ...
  • Εξαγωγή κειμένου, Προσθήκη κειμένου, Κατάργηση κατά θέση, Αφαιρέστε το διάστημα; Δημιουργία και εκτύπωση υποσύνολων σελιδοποίησης. Μετατροπή περιεχομένου και σχολίων μεταξύ κελιών...
  • Σούπερ φίλτρο (αποθηκεύστε και εφαρμόστε σχήματα φίλτρων σε άλλα φύλλα). Προηγμένη ταξινόμηση ανά μήνα / εβδομάδα / ημέρα, συχνότητα και άλλα. Ειδικό φίλτρο με έντονη, πλάγια ...
  • Συνδυάστε βιβλία εργασίας και φύλλα εργασίας; Συγχώνευση πινάκων βάσει βασικών στηλών. Διαχωρίστε τα δεδομένα σε πολλά φύλλα; Μαζική μετατροπή xls, xlsx και PDF...
  • Περισσότερα από 300 ισχυρά χαρακτηριστικά. Υποστηρίζει Office / Excel 2007-2021 και 365. Υποστηρίζει όλες τις γλώσσες. Εύκολη ανάπτυξη στην επιχείρηση ή τον οργανισμό σας. Πλήρεις δυνατότητες δωρεάν δοκιμής 30 ημερών. Εγγύηση επιστροφής χρημάτων 60 ημερών.
kte καρτέλα 201905

Το Office Tab φέρνει τη διεπαφή με καρτέλες στο Office και κάνει την εργασία σας πολύ πιο εύκολη

  • Ενεργοποίηση επεξεργασίας και ανάγνωσης καρτελών σε Word, Excel, PowerPoint, Publisher, Access, Visio και Project.
  • Ανοίξτε και δημιουργήστε πολλά έγγραφα σε νέες καρτέλες του ίδιου παραθύρου και όχι σε νέα παράθυρα.
  • Αυξάνει την παραγωγικότητά σας κατά 50% και μειώνει εκατοντάδες κλικ του ποντικιού για εσάς κάθε μέρα!
κάτω μέρος γραφείου
Σχόλια (299)
Δεν υπάρχουν ακόμη βαθμολογίες. Γίνε ο πρώτος που θα αξιολογήσετε!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σας, βρήκα αυτόν τον συγκεκριμένο οδηγό πολύ χρήσιμο σε σχέση με άλλους που έχω δει. Σας ευχαριστώ! Το πρόβλημα που αντιμετωπίζω είναι ότι αν αλλάξω την επιθυμητή τιμή σε 'Κλειστό' θα πρέπει να εκτελέσω το F5 για να μετακινήσω τη σειρά. Θα ήθελα να κινείται αυτόματα. Είμαι νέος στο Excel, επομένως η βοήθειά σας εκτιμάται ιδιαίτερα. Sub Cheezy() Dim xRg As Range Dim xCell As Range Dim I As Long Dim J As Long I = Φύλλα εργασίας("ECR Incident Tracker").UsedRange.Rows.Count J = Worksheets("Resolved Issues").UsedRange.Σειρές. Μετρήστε Αν J = 1 Τότε Αν Εφαρμογή.Φύλλο εργασίαςΣυνάρτηση.CountA(Worksheets("Resolved Issues").UsedRange) = 0 Στη συνέχεια J = 0 Τέλος εάν οριστεί xRg = Φύλλα εργασίας("ECR Incident Tracker").Range("B1:B" & I) On Error Resume Next Application.ScreenUpdating = False For Every xCell In xRg If CStr(xCell.Value) = "Closed" then xCell.EntireRow.Copy Destination:=Worksheets("Resolved Issues").Range("A" & J + 1) xCell.EntireRow.Delete J = J + 1 End If Next Application.ScreenUpdating = True End Sub
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σας, προσπαθώ να αυτοματοποιήσω τη μετακίνηση των κελιών χωρίς να χρειάζεται να ανοίξω τη μονάδα και να πατήσω επίσης το F5. Επιλύσατε ποτέ αυτήν την ερώτηση; Ευχαριστώ εκ των προτέρων!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Η Crystal έδωσε πληροφορίες για το πώς να το κάνετε αυτό σήμερα - ρίξτε μια ματιά στη σελίδα XNUMX αυτού του νήματος για να δείτε την απάντησή της. Μετακινεί αυτόματα τη σειρά με τη σημερινή ημερομηνία σε μια στήλη (L στην περίπτωσή μου) σε διαφορετικό φύλλο εργασίας.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Εκτελώ αυτόν τον κωδικό και προσπαθώ να μετακινήσω μια σειρά με βάση τη σημερινή ημερομηνία που εμφανίζεται στη στήλη I - Έχω αλλάξει το εύρος ("B1:B" & I) για να διαβάσω το εύρος (I1:I" & I) . Έχω αλλάξει " Ολοκληρώθηκε" στο παράδειγμά σας στην ημερομηνία. Ωστόσο, όταν η σημερινή ημερομηνία εμφανίζεται οπουδήποτε στη σειρά, όχι μόνο στη στήλη I, όπως απαιτείται, η σειρά μετακινείται στο εναλλακτικό φύλλο εργασίας. Οποιαδήποτε ιδέα γιατί συμβαίνει αυτό και πώς μπορώ να κάνω τη μετακίνηση της σειράς μόνο όταν η σημερινή ημερομηνία είναι στη στήλη I, ανεξάρτητα από το αν η σημερινή ημερομηνία εμφανίζεται σε άλλες στήλες;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αν ήθελα να έχω πολλές τιμές και πολλά φύλλα για να μετακινήσω τη σειρά μου, θα έπρεπε να γράψω ξανά ολόκληρο τον κώδικα με διαφορετική τιμή για αυτό το κελί; Δηλαδή, αν βάλω NA σε ένα κελί πηγαίνει σε φύλλο Na και αν βάλω W# θα πάει σε λάθος αριθμητικό φύλλο κ.λπ.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
γεια, αυτό ήταν πολύ χρήσιμο. Υπάρχει τρόπος να γίνει αυτό χωρίς να μετακινηθεί η σειρά δεδομένων στο δεύτερο φύλλο, αλλά να αντιγραφεί; Άρα τα δεδομένα θα παρέμεναν και στα δύο φύλλα;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια, ο κώδικας ήταν πολύ χρήσιμος, αλλά αντί να αντιγράψω ολόκληρη τη σειρά, απαιτώ μια συγκεκριμένη επιλογή σειράς να μετακινηθεί στο επόμενο φύλλο. πώς μπορώ να ορίσω ένα εύρος αντί για μια ολόκληρη σειρά Sub Cheezy() Dim xRg ως εύρος Dim xCell ως εύρος Dim I Ως μήκος Dim J As Long I = Worksheets("Sheet1").UsedRange.Rows.Count J = Worksheets(" Sheet2").UsedRange.Rows.Count If J = 1 then If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Τότε J = 0 End If Set xRg = Φύλλα εργασίας("Φύλλο1").Range( "C1:C" & I) On Error Resume Next Application.ScreenUpdating = False For Every xCell In xRg If CStr(xCell.Value) = "Done" Τότε xCell.EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1) J = J + 1 End If Next Application.ScreenUpdating = True End Sub
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
ποιος θα ήταν ο κώδικας αν θέλω να αντιγράψω σειρές (συγκεκριμένα κελιά) σε ένα άλλο φύλλο σε συγκεκριμένα κελιά; ΑΛΛΑ επίσης βασίζεται σε ένα Παράδειγμα αξίας: έγχρωμη συμβολοσειρά εικόνων προϊόντων λευκό μπλέντερ 2 whiteblender2 μαύρο αποχυμωτή 3 blackjuicer3 κόκκινη τηλεόραση 1 redtv1 πράσινο σίδερο 4 greeniron4 Θα ήθελα η συμβολοσειρά να αντιγραφεί σε άλλο φύλλο αλλά ο αριθμός στη στήλη εικόνων λέει πόσες φορές πρέπει να αντιγραφεί (έτσι, σε αυτήν την περίπτωση, η συμβολοσειρά του μπλέντερ πρέπει να αντιγραφεί σε 2 σειρές
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια, Πολύ ωραίο κομμάτι κώδικα, λειτουργεί πολύ καλά. Πώς να αλλάξετε αυτόν τον κώδικα για να μετακινήσετε σειρές από έναν πίνακα σε άλλο πίνακα, αντί για ένα φύλλο σε άλλο φύλλο; Πολλά ευχαριστώ !
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια, Προσπαθώ να χρησιμοποιήσω τον κώδικα, αλλά λαμβάνω ένα συντακτικό σφάλμα στο Dim xCell As Range. Μπορείτε να βοηθήσετε σας παρακαλώ;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Sub Cheezy() Dim xRg As Range Dim xCell As Range Dim I As Long Dim J As Long I = Worksheets("Sheet1").UsedRange.Rows.Count J = Worksheets("Sheet2").UsedRange.Rows.Count If J = 1 Τότε Αν Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Τότε J = 0 End If Set xRg = Worksheets("Sheet1").Range("C1:C" & I) On Error Resume Next Application.ScreenUpdating = False For Every xCell In xRg If CStr(xCell.Value) = "Done" Τότε xCell.EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1) xCell. EntireRow.Delete J = J + 1 End If Next Application.ScreenUpdating = True End Sub Πώς μπορώ να προσθέσω ένα δεύτερο φύλλο εργασίας για να μεταφερθούν σειρές στο φύλλο2;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Τι πρέπει να εισάγω εάν θέλω να συμπεριλάβω κάποια ημερομηνία ως τιμή μου; Άρα η σειρά παραμένει στο φύλλο 1 αν δεν έχει ημερομηνία και μετακινείται στο φύλλο 2 αν έχει;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
[quote]Γεια, αυτό ήταν πολύ χρήσιμο. Υπάρχει τρόπος να γίνει αυτό χωρίς να μετακινηθεί η σειρά δεδομένων στο δεύτερο φύλλο, αλλά να αντιγραφεί; Άρα τα δεδομένα θα παρέμεναν και στα δύο φύλλα;Από τη Μάντι[/quote] το έλυσε κανείς αυτό
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Καταργήστε αυτό το "xCell.EntireRow.Delete" από τον κώδικα
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Όταν διαγράφω αυτήν τη γραμμή κώδικα και εκτελώ ξανά τη μακροεντολή, το Excel παγώνει. Γιατί και πώς το διορθώνω;; Θέλω τα δεδομένα να υπάρχουν και στα δύο φύλλα εργασίας και να μην διαγράφονται από το πρωτότυπο. TIA
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
υπάρχει απάντηση σε αυτό; Το δικό μου παγώνει επίσης Θα ήθελα να αντιγράψω αλλά όχι να διαγράψω τη σειρά
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Καλή μέρα,
Ο παρακάτω κώδικας VBA μπορεί να σας βοηθήσει να αντιγράψετε μόνο τις σειρές αντί να τις διαγράψετε.

Sub Cheezy()
Dim xRg ως εύρος
Dim xCell ως εύρος
Dim I As Long
Dim J As Long
Dim K As Long
I = Φύλλα εργασίας ("Φύλλο1").UsedRange.Rows.Count
J = Φύλλα εργασίας ("Φύλλο2").UsedRange.Rows.Count
Αν J = 1 Τότε
Αν Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Τότε J = 0
End If
Ορισμός xRg = Φύλλα εργασίας ("Φύλλο1"). Εύρος ("C1:C" & I)
On Error Συνέχιση Επόμενη
Application.ScreenUpdating = False
Για K = 1 To xRg.Count
Αν CStr(xRg(K).Value) = "Done" Τότε
xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
J = J + 1
End If
Επόμενο
Application.ScreenUpdating = True
Sub End
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια, ψάχνω για μια παραλλαγή σε αυτό. Χρειάζομαι το σενάριο να εκτελείται συνεχώς, ή να αποτύχει κάθε φορά που αλλάζει η τιμή σε αυτό το συγκεκριμένο πεδίο. Ο ίδιος ο κώδικας λειτουργεί αλλά πρέπει να εκτελείται ανεξάρτητα. Θα ήθελα να είναι αυτοματοποιημένο. Μπορεί κάποιος να βοηθήσει;

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

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

Προσωπικό φύλλο εργασίας Sub_change (ByVal Target As Range)

Dim xCell ως εύρος

Dim I As Long
On Error Συνέχιση Επόμενη

Application.ScreenUpdating = False

Ορισμός xCell = Στόχος (1)
Αν xCell.Value = "Τέλος" Τότε
I = Φύλλα εργασίας ("Φύλλο2").UsedRange.Rows.Count
Αν I = 1 Τότε

Αν Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Τότε I = 0

End If

xCell.EntireRow.Copy φύλλα εργασίας("Sheet2").Range("A" & I + 1)

xCell.EntireRow.Delete
End If

Application.ScreenUpdating = True

Sub End


Για τη δεύτερη ερώτησή σας, εννοείτε απλώς να αντιγράψετε πολλά κελιά αντί για ολόκληρη τη σειρά; Ή θα θέλατε να δώσετε ένα στιγμιότυπο οθόνης της ερώτησής σας; Σας ευχαριστώ!

Με εκτίμηση, Crystal
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Κρύσταλλο,


Η βοήθειά σας είναι περισσότερο από απαραίτητη :)



Πώς μπορούμε να προσθέσουμε ένα άλλο κριτήριο εδώ, για παράδειγμα θα ήθελα να μεταφέρω Ολοκληρώθηκε δίπλα στο Τέλος:


Προσωπικό φύλλο εργασίας Sub_change (ByVal Target As Range)

Dim xCell ως εύρος

Dim I As Long
On Error Συνέχιση Επόμενη

Application.ScreenUpdating = False

Ορισμός xCell = Στόχος (1)
Αν xCell.Value = "Τέλος" Τότε
I = Φύλλα εργασίας ("Φύλλο2").UsedRange.Rows.Count
Αν I = 1 Τότε

Αν Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Τότε I = 0

End If

xCell.EntireRow.Copy φύλλα εργασίας("Sheet2").Range("A" & I + 1)

xCell.EntireRow.Delete
End If

Application.ScreenUpdating = True

Sub End
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Crystal
Αυτές είναι οι πιο χρήσιμες πληροφορίες που έχω βρει στον Ιστό και αυτή η μακροεντολή κάνει αυτό που θέλω. Αλλά μεταφέρω τις σειρές από έναν πίνακα σε έναν άλλο πίνακα - και με αυτήν τη μακροεντολή οι πληροφορίες μετακινούνται στην πρώτη ελεύθερη γραμμή έξω από τον πίνακα, όχι στην επόμενη ελεύθερη γραμμή στον πίνακα; Μπορεις να βοηθησεις?
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Εκτελώ αυτόν τον κωδικό και προσπαθώ να μετακινήσω μια σειρά με βάση τη σημερινή ημερομηνία που εμφανίζεται στη στήλη I - Έχω αλλάξει το εύρος ("B1:B" & I) για να διαβάσω το εύρος (I1:I" & I) . Έχω αλλάξει " Ολοκληρώθηκε" στο παράδειγμά σας στην ημερομηνία. Ωστόσο, όταν η σημερινή ημερομηνία εμφανίζεται οπουδήποτε στη σειρά, όχι μόνο στη στήλη I, όπως απαιτείται, η σειρά μετακινείται στο εναλλακτικό φύλλο εργασίας. Οποιαδήποτε ιδέα γιατί συμβαίνει αυτό και πώς μπορώ να κάνω τη μετακίνηση της σειράς μόνο όταν η σημερινή ημερομηνία είναι στη στήλη I, ανεξάρτητα από το αν η σημερινή ημερομηνία εμφανίζεται σε άλλες στήλες;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αγαπητέ David,

Ο κώδικας λειτουργεί καλά για μένα μετά την αλλαγή του εύρους και της τιμής παραλλαγής μέχρι σήμερα. Η μορφή ημερομηνίας στον κώδικά σας πρέπει να ταιριάζει με τη μορφή ημερομηνίας που χρησιμοποιήσατε στο φύλλο εργασίας. Ή σας βολεύει να επισυνάψετε το φύλλο εργασίας σας;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Crystal,


Δεν καταλαβαίνω τι εννοείτε όταν λέτε ότι οι μορφές ημερομηνίας κώδικα και υπολογιστικού φύλλου πρέπει να ταιριάζουν - δεν είμαι ειδικός της VB, περισσότερο αρχάριος. Στο υπολογιστικό φύλλο μου εισάγω τη σημερινή ημερομηνία στη στήλη F ως ημερομηνία καταχώρισης της σειράς, με τη μορφή ctrl + :. Εισάγω την ημερομηνία λήξης στη στήλη "Ι" σε μορφή μμ/ηη/εεεε. Ωστόσο, αυτό προκαλεί προβλήματα κατά την καταχώριση νέας σειράς και την εισαγωγή της σημερινής ημερομηνίας στη στήλη F, επειδή, μόλις εισαχθεί, η σειρά μετακινείται στο νέο φύλλο εργασίας. Επιπλέον, ο πρόσθετος κωδικός που θα εκτελείται κάθε φορά που ανοίγει το βιβλίο εργασίας δεν εμφανίζεται να τρέξει χωρίς να το αναγκάσω να το κάνει. Συγγνώμη για ό,τι μπορεί να είναι για εσάς πολύ ασήμαντα ζητήματα, αλλά δεν μπορώ να ακούσω τα σχετικά με αυτά τα θέματα. Οποιαδήποτε βοήθεια θα εκτιμηθεί.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αγαπητέ David,

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

Με εκτίμηση, Crystal
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Crystal, αυτά είναι τα σχετικά φύλλα εργασίας. Θα δείτε στον αντιγραμμένο κωδικό ότι ψάχνω για "έως " η σημερινή ημερομηνία στη στήλη L και εάν το "έως" και συμπεριλαμβανομένης της σημερινής ημερομηνίας βρίσκεται σε αυτήν τη στήλη, τότε θέλω να μετακινήσω τη σειρά που περιέχει αυτήν την ημερομηνία σε ένα νέο φύλλο εργασίας. Επί του παρόντος, όταν εισάγω τη σημερινή ημερομηνία οπουδήποτε στη σειρά (για παράδειγμα, στήλη F, εάν εκδοθεί πρόσκληση σήμερα), μετακινεί αυτόματα ολόκληρη τη σειρά στο αρχειοθετημένο υπολογιστικό φύλλο. Συνήθως εισάγω τη σημερινή ημερομηνία χρησιμοποιώντας τον συνδυασμό ctrl + :, συνήθως στη στήλη F.
Επιπλέον, θα ήθελα αυτή η κίνηση να συμβεί όταν ανοίγω το βιβλίο εργασίας. Αυτήν τη στιγμή πρέπει να πάω για να εμφανίσω τον κωδικό και μετά να πατήσω το F5. Οποιαδήποτε συμβουλή για το πώς να το κάνετε αυτό θα ήταν ευπρόσδεκτη.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Δυστυχώς το βιβλίο εργασίας μου με δυνατότητα μακροεντολής δεν θα μεταφορτωθεί καθώς λέει ότι η μορφή δεν υποστηρίζεται. Αυτά είναι στο Excel 2016
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αγαπητέ David,

Ο παρακάτω κώδικας VBA μπορεί να σας βοηθήσει να το πετύχετε.

Ιδιωτικό Sub Workbook_Open ()
Dim xRg ως εύρος
Dim xCell ως εύρος
Dim I As Long
Dim J As Long
I = Φύλλα εργασίας ("ΤΡΕΧΟΝΤΕΣ ΕΥΚΑΙΡΙΕΣ OASIS").UsedRange.Rows.Count
J = Φύλλα εργασίας ("ΑΡΧΕΙΟΜΕΝΕΣ ΕΥΚΑΙΡΙΕΣ OASIS").UsedRange.Rows.Count
Αν J = 1 Τότε
Εάν Application.WorksheetFunction.CountA(Worksheets("ARCHIVED OASIS OPPORTUNITIES").UsedRange) = 0 Τότε J = 0
End If
Ορισμός xRg = Φύλλα εργασίας ("ΤΡΕΧΟΝΤΕΣ ΕΥΚΑΙΡΙΕΣ OASIS"). Εύρος ("L1:L" & I)
On Error Συνέχιση Επόμενη
Application.ScreenUpdating = False
Για κάθε xCell σε xRg
Αν CStr(xCell.Value) = Ημερομηνία Τότε
xCell.EntireRow.Copy Destination:=Worksheets("ARCHIVED OASIS OPPORTUNITIES").Range("A" & J + 1)
xCell.EntireRow.Delete
J = J + 1
End If
Επόμενο
Sub End

:
1. Πρέπει να βάλετε τη δέσμη ενεργειών VBA στο παράθυρο κώδικα ThisWorkbook.
2. Το βιβλίο εργασίας σας πρέπει να αποθηκευτεί ως Βιβλίο εργασίας με δυνατότητα Macro-Enabled του Excel.

Μετά την παραπάνω λειτουργία, κάθε φορά που ανοίγετε το βιβλίο εργασίας, μια ολόκληρη σειρά θα μετακινείται στο ΑΡΧΕΙΟΜΕΝΟ φύλλο εργασίας εάν το κελί της στήλης L φτάσει στη σημερινή ημερομηνία.

Beast Regards, Crystal
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Ευχαριστώ Crystal,
Αυτό λειτουργεί εξαιρετικά εάν η σημερινή ημερομηνία επιτυγχάνεται στη στήλη L. Υπάρχει κάποιος τρόπος να συμπεριληφθεί η σημερινή ημερομηνία και στη στήλη L, έτσι ώστε εάν δεν ελέγξω το βιβλίο εργασίας για αρκετές ημέρες, θα περιλαμβάνει αυτόματα προηγούμενες ημερομηνίες πριν από την σημερινή? Σας ευχαριστώ πολύ για τη βοήθειά σας.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αγαπητέ David,

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

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



Καταλαβαίνω την άποψή σου. Δοκιμάστε το παρακάτω σενάριο VBA. Όταν ανοίξετε το βιβλίο εργασίας, όλες οι σειρές με ημερομηνίες έως τη σημερινή ημερομηνία στη στήλη L θα μετακινηθούν σε νέο καθορισμένο φύλλο.



Ιδιωτικό Sub Workbook_Open ()
Dim xRg ως εύρος
Dim xRgRtn ως εύρος
Dim xCell ως εύρος
Dim xLastRow As Long
Dim I As Long
Dim J As Long
On Error Συνέχιση Επόμενη
xLastRow = Φύλλα εργασίας ("CURRENT OASIS OPPORTUNITIES").UsedRange.Rows.Count
Αν xLastRow < 1 Τότε βγείτε από το Sub
J = Φύλλα εργασίας ("ΑΡΧΕΙΟΜΕΝΕΣ ΕΥΚΑΙΡΙΕΣ OASIS").UsedRange.Rows.Count
Αν J = 1 Τότε
Εάν Application.WorksheetFunction.CountA(Worksheets("ARCHIVED OASIS OPPORTUNITIES").UsedRange) = 0 Τότε J = 0
End If
Ορισμός xRg = Φύλλα εργασίας ("ΤΡΕΧΟΝΤΕΣ ΕΥΚΑΙΡΙΕΣ OASIS"). Εύρος ("L1:L" & xΤελευταία σειρά)
Για I = 2 έως xLastRow
Εάν xRg(I)
Αν xRg(I).Τιμή <= Ημερομηνία Τότε
xRg(I).EntireRow.Copy Destination:=Worksheets("ARCHIVED OASIS OPPORTUNITIES").Range("A" & J + 1)
xRg(I).EntireRow.Delete
J = J + 1
I = I - 1
End If
Επόμενο
Sub End

Πρέπει να τοποθετήσετε τη δέσμη ενεργειών VBA στο παράθυρο κώδικα ThisWorkbook και να αποθηκεύσετε το βιβλίο εργασίας ως βιβλίο εργασίας με δυνατότητα Macro-Enabled του Excel.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Ευχαριστώ Crystal, αυτό λειτουργεί μια χαρά.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Crystal, ήμουν λίγο βιαστικός να απαντήσω ότι ο κώδικας λειτούργησε. Άνοιξα το βιβλίο εργασίας μου σήμερα και οι σειρές που περιέχουν καταχωρήσεις προηγούμενης ημερομηνίας στο κελί της στήλης L εξακολουθούν να βρίσκονται στο "τρέχον φύλλο εργασίας ευκαιριών όασης" και δεν έχουν μετακινηθεί στο "αρχειοθετημένο φύλλο εργασίας όασης" όπως αναμενόταν. Καμιά ιδέα γιατί να συμβαίνει αυτό;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Τα επισημασμένα κελιά βρίσκονται στη στήλη L σε σχέση με την παραπάνω ερώτηση και αποτελούν τα κριτήρια (μέχρι σήμερα) για τη μετακίνηση της σειράς στο νέο φύλλο εργασίας. Ελπίζω αυτή η εικόνα να βοηθήσει.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αυτό είναι επίσης ένα αντίγραφο του παραθύρου VBA που σχετίζεται με τα παραπάνω.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Crystal, ήμουν λίγο βιαστικός να απαντήσω ότι ο κώδικας λειτούργησε. Άνοιξα το βιβλίο εργασίας μου σήμερα και οι σειρές που περιέχουν καταχωρήσεις προηγούμενης ημερομηνίας στο κελί της στήλης L εξακολουθούν να βρίσκονται στο "τρέχον φύλλο εργασίας ευκαιριών όασης" και δεν έχουν μετακινηθεί στο "αρχειοθετημένο φύλλο εργασίας όασης" όπως αναμενόταν. Καμιά ιδέα γιατί να συμβαίνει αυτό;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Κρύσταλλο,

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

ABCDEFGHIJKL
# Τύπος Παράκληση για παύση της καλλιέργειας Τροποποίηση # Ημερομηνία έκδοσης Ερωτήσεις Τοποθεσία παράδοσης πελάτη Πρόταση έργου Οφειλόμενη

1 SS SB 1234567 1 09/6/17 No Army Name Place Drive Tank 09/10/17

Χρησιμοποιώντας τον παρακάτω κώδικα, θέλω να μετακινήσει μια ολόκληρη σειρά σε ένα νέο φύλλο εργασίας όταν η στήλη L φτάσει στη σημερινή ημερομηνία. Επίσης, εάν δεν έχω συμπληρώσει το φύλλο εργασίας για αρκετές ημέρες, θα ήθελα να χρησιμοποιήσει την αναζήτηση "μέχρι σήμερα" στη στήλη L για να κάνει το ίδιο. Θα ήθελα επίσης να το κάνει αυτό αυτόματα όταν ανοίγω το βιβλίο εργασίας, αν είναι δυνατόν. Προς το παρόν, εάν εισαγάγω τη σημερινή ημερομηνία σε οποιοδήποτε κελί της σειράς, για παράδειγμα στη στήλη F κατά την εισαγωγή δεδομένων, ολόκληρη η σειρά μετακινείται στο φύλλο εργασίας αρχειοθέτησης. (Χρησιμοποιώντας το Excel 2016)

[Κωδικός ενότητας 1]

Sub DaveV()

Dim xRg ως εύρος

Dim xCell ως εύρος

Dim I As Long

Dim J As Long

I = Φύλλα εργασίας ("ΤΡΕΧΟΝΤΕΣ ΕΥΚΑΙΡΙΕΣ OASIS").UsedRange.Rows.Count

J = Φύλλα εργασίας ("ΑΡΧΕΙΟΜΕΝΕΣ ΕΥΚΑΙΡΙΕΣ OASIS").UsedRange.Rows.Count

Αν J = 1 Τότε
Εάν Application.WorksheetFunction.CountA(Worksheets("ARCHIVED OASIS OPPORTUNITIES").UsedRange) = 0 Τότε J = 0

End If

Ορισμός xRg = Φύλλα εργασίας ("ΤΡΕΧΟΝΤΕΣ ΕΥΚΑΙΡΙΕΣ OASIS"). Εύρος ("L1:L" & I)

On Error Συνέχιση Επόμενη

Application.ScreenUpdating = False

Για κάθε xCell σε xRg

Αν CStr(xCell.Value) = Ημερομηνία Τότε

xCell.EntireRow.Copy Destination:=Worksheets("ARCHIVED OASIS OPPORTUNITIES").Range("A" & J + 1)
xCell.EntireRow.Delete

J = J + 1
End If

Επόμενο
Application.ScreenUpdating = True

Sub End
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
[Κωδικός Φύλλου 1]

Προσωπικό φύλλο εργασίας Sub_change (ByVal Target As Range)
Dim xCell ως εύρος
Dim I As Long
On Error Συνέχιση Επόμενη
Application.ScreenUpdating = False
Ορισμός xCell = Στόχος (1)
Αν xCell.Value = Ημερομηνία Τότε
I = Φύλλα εργασίας ("ΑΡΧΕΙΟΜΕΝΕΣ ΕΥΚΑΙΡΙΕΣ OASIS").UsedRange.Rows.Count
Αν I = 1 Τότε
Εάν Application.WorksheetFunction.CountA(Worksheets("ARCHIVED OASIS OPPORTUNITIES").UsedRange) = 0 Τότε I = 0 Τέλος Εάν
xCell.EntireRow.Αντιγραφή φύλλων εργασίας ("ΑΡΧΕΙΟΜΕΝΕΣ ΕΥΚΑΙΡΙΕΣ OASIS"). Εύρος ("A" & I + 1)
xCell.EntireRow.Delete
End If
Application.ScreenUpdating = True
Sub End

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

Ας πούμε ότι εντοπίσατε ότι η σειρά 7 έχει τη λέξη "Τέλος" στη στήλη Γ, επομένως την αντιγράφετε και διαγράφετε τη σειρά.
Μόλις διαγράψετε τη σειρά, η επόμενη σειρά στη λίστα θα είναι η σειρά 9 και όχι η 8, γιατί μόλις αφαιρέσατε την 7η γραμμή, τώρα το περιεχόμενο της 8ης γραμμής βρίσκεται στη γραμμή 7 και όλες οι γραμμές ανέβηκαν 1 σειρά. Έτσι, η επόμενη σειρά για έλεγχο υποτίθεται ότι ήταν η σειρά #8, αλλά τώρα περιέχει τα δεδομένα που ήταν προηγουμένως στη σειρά #9, οπότε κάθε φορά που διαγράφετε μια σειρά, στην πραγματικότητα παραλείπετε μια σειρά για έλεγχο!!!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αγαπητέ Shau Alon,

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

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

Sub Cheezy()
«Ενημερώθηκε από το Kutools για το Excel 2017/8/28
Dim xRg ως εύρος
Dim xCell ως εύρος
Dim I As Long
Dim J As Long
Dim K As Long
I = Φύλλα εργασίας ("ΠΡΟΒΛΕΨΗ ΑΓΟΡΑΣ").UsedRange.Rows.Count
J = Φύλλα εργασίας ("Αρχείο αγοράς").UsedRange.Rows.Count
Αν J = 1 Τότε
Εάν Application.WorksheetFunction.CountA(Worksheets("Purchase Archive").UsedRange) = 0 Τότε J = 0
End If
Ορισμός xRg = Φύλλα εργασίας ("ΠΡΟΒΛΕΨΗ ΑΓΟΡΑΣ"). Εύρος ("H3:H" & I)
On Error Συνέχιση Επόμενη
Application.ScreenUpdating = False
Για K = 1 To xRg.Count
Αν CStr(xRg(K).Value) = "Ναι" Τότε
xRg(K).EntireRow.Copy Destination:=Worksheets("Purchase Archive").Range("A" & J + 1)
xRg(K).EntireRow.Delete
Αν CStr(xRg(K).Value) = "Ναι" Τότε
Κ = Κ - 1
End If
J = J + 1
End If
Επόμενο
Application.ScreenUpdating = True
Sub End
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια Φρεντ,
Κάθε φορά που εκτελείτε τον κώδικα, ο κώδικας αναζητά το καθορισμένο εύρος, επομένως αντιγράφει την ίδια σειρά ξανά και ξανά, επειδή δεν μπορεί να πει ποια σειρά έχει ήδη αντιγραφεί. Για να αποφύγετε την επανειλημμένη αντιγραφή της ίδιας σειράς, μπορείτε να εκτελέσετε αυτόματα τον κώδικα όταν εισαγάγετε μια αντίστοιχη τιμή στο καθορισμένο κελί.
Στο φύλλο εργασίας με το όνομα "ΠΡΟΒΛΕΨΗ ΑΓΟΡΑΣ", κάντε δεξί κλικ στην καρτέλα του φύλλου και κάντε κλικ Προβολή κωδικού από το μενού περιβάλλοντος. Στη συνέχεια, αντιγράψτε τον ακόλουθο κώδικα VBA στο παράθυρο Φύλλο (Κωδικός).

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Updated by Kutools for Excel 20220830
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("PURCHASE FORCAST").UsedRange.Rows.Count
J = Worksheets("Purchase Archive").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Purchase Archive").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("PURCHASE FORCAST").Range("H3:H" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Yes" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Purchase Archive").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "Yes" Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Θα μπορούσε κάποιος να με βοηθήσει να κάνω αυτό το έργο; Προσπάθησα να αλλάξω το τμήμα που πρέπει να ταιριάζει με το αρχείο μου, αλλά εμφανίζεται αυτό και δεν είμαι σίγουρος τι να κάνω.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
λέει ότι το αρχείο δεν υποστηρίζεται όταν προσπαθώ να ανεβάσω το αρχείο excel. Συγγνώμη... παλεύω με αυτό σήμερα.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Θα ήθελα βοήθεια για μια παρόμοια εργασία, αλλά λίγο διαφορετική. Έχω 5 στήλες αριθμών, περίπου 25000 ανά στήλη, κάθε στήλη με επικεφαλίδα 1-5. Θα ήθελα να αντιγράψω ολόκληρη τη σειρά σε άλλο φύλλο, εάν η τιμή της στήλης 1 είναι μεγαλύτερη από μηδέν, Ή της στήλης 2 είναι μεγαλύτερη από μηδέν , Ή η στήλη 3 είναι μικρότερη από το μηδέν, Ή η στήλη 4 είναι μεγαλύτερη από πέντε Ή η στήλη 5 είναι μεγαλύτερη από δύο κ.λπ. είναι δυνατόν;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
η μεταφόρτωση εικόνας δεν λειτουργεί... συγγνώμη.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Χαίρετε Κ.
Χρησιμοποιήστε το κουμπί μεταφόρτωσης αυτού.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Έτσι, ο στόχος είναι να δούμε εάν κάποιο από τα αέρια είναι πάνω από ένα όριο που θα ορίσω στον τύπο, ολόκληρο το αυγοτάραχο ΑΝΤΙΓΡΑΦΕΙ σε ένα νέο φύλλο.

Σας ευχαριστώ πολύ για οποιαδήποτε βοήθεια.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Επισυνάπτεται εικόνα
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αγαπητέ Μιχάλη,
Ίσως μπορείτε να λύσετε αυτό το πρόβλημα χρησιμοποιώντας ένα πρόσθετο Excel. Εδώ σας προτείνω το βοηθητικό πρόγραμμα Select Specific Cells του Kutools για Excel. Με αυτό το βοηθητικό πρόγραμμα, μπορείτε εύκολα να επιλέξετε όλες τις σειρές σε ένα συγκεκριμένο εύρος, εάν η τιμή μιας καθορισμένης στήλης είναι μεγαλύτερη ή μικρότερη από έναν αριθμό. Αφού επιλέξετε όλες τις απαραίτητες σειρές, μπορείτε να τις αντιγράψετε και να τις επικολλήσετε χειροκίνητα σε ένα νέο φύλλο εργασίας. Δείτε παρακάτω τη συνημμένη εικόνα.

Μπορείτε να μάθετε περισσότερα για αυτήν τη δυνατότητα ακολουθώντας τον παρακάτω υπερσύνδεσμο.
https://www.extendoffice.com/product/kutools-for-excel/excel-select-specific-cells-rows.html
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
ευχαριστώ για αυτόν τον τύπο, αλλά είχα ένα πρόβλημα που είναι ότι όταν θέλω να μετακινήσω τη σειρά σε άλλο φύλλο, δεν συμβαίνει αυτόματα. μπορείς να μου δώσεις άλλη φόρμουλα; οπότε όποτε αλλάζω την τιμή του κελιού, μετακινήθηκε αυτόματα.


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

Θα ήθελα να ρυθμίσω αυτήν τη μακροεντολή αλλά με 2 ορίσματα. Κατάφερα να βάλω τη μακροεντολή να λειτουργεί στο αρχείο μου με βάση την τιμή των κελιών στη στήλη O. Ωστόσο, θα ήθελα η μακροεντολή να ελέγξει εάν η στήλη S είναι επίσης συμπληρωμένη (ή <> ""), πριν μετακινηθεί η σειρά . Τέλος, θα ήθελα επίσης οι αντιγραμμένες σειρές να έχουν την ίδια μορφοποίηση με τις σειρές στο δεύτερο φύλλο. Αυτό αλλάζει εντελώς τη μακροεντολή;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αγαπητέ Hugues,
Δεν ξέρω αν σε καταλαβαίνω σωστά. Εννοείτε ότι εάν το κελί στη στήλη S είναι συμπληρωμένο και το κελί στη στήλη Ο περιέχει τη συγκεκριμένη τιμή ταυτόχρονα, τότε μετακινήστε τη σειρά με μορφοποίηση; Διαφορετικά, μην κουνηθείς;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Crystal,

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


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

Sub MoveRowBasedOnCellValue()
Dim xRgStatus As Range
Dim xRgDate ως εύρος
Dim I As Long
Dim J As Long
Dim K As Long
I = Φύλλα εργασίας ("Φύλλο1").UsedRange.Rows.Count
J = Φύλλα εργασίας ("Φύλλο2").UsedRange.Rows.Count
Αν J = 1 Τότε
Αν Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Τότε J = 0
End If
Ορισμός xRgStatus = Φύλλα εργασίας ("Φύλλο1"). Εύρος ("O1:O" & I)
Ορισμός xRgDate = Φύλλα εργασίας ("Φύλλο1"). Εύρος ("S1:S" & I)
On Error Συνέχιση Επόμενη
Application.ScreenUpdating = False
Application.CutCopyMode = Λάθος
xRgStatus(1).EntireRow.Copy
Φύλλα εργασίας("Φύλλο2").Range("A" & J + 1).PasteSpecial xlPasteAllUsingSourceTheme
J = J + 1
Για K = 2 Σε xRgStatus.Count
Αν CStr(xRgStatus(K).Value) = "Closed" Τότε
Αν (xRgDate(K).Value <> "") And (TypeName(xRgDate(K).Value) = "Date") Τότε
xRgStatus(K).EntireRow.Αντιγραφή
Φύλλα εργασίας("Φύλλο2").Range("A" & J + 1).PasteSpecial xlPasteAllUsingSourceTheme
J = J + 1
End If
End If
Επόμενο
Application.CutCopyMode = True
Application.ScreenUpdating = True
Sub End
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αγαπητέ Crystal,

Σας ευχαριστώ πολύ για τη βοήθειά σας!

Χαιρετισμούς,

Hugues
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Χαίρετε Κ.


Πώς μπορώ να αντιγράψω τις σειρές αντί να τις μετακινήσω;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Χαίρετε Κ.


Ξέρω ότι αυτό έχει δημοσιευτεί αρκετές φορές αλλά δεν μπορώ να βρω την απάντηση. Πώς μπορώ να αντιγράψω το υλικό στο νέο φύλλο και να ΜΗΝ το διαγράψω από το αρχικό φύλλο;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αγαπητέ Mike,
Εάν θέλετε να αντιγράψετε τις σειρές αντί να τις διαγράψετε, ο παρακάτω κώδικας VBA μπορεί να σας βοηθήσει. Σας ευχαριστούμε για το σχόλιό σας!

Sub Cheezy()
Dim xRg ως εύρος
Dim xCell ως εύρος
Dim I As Long
Dim J As Long
Dim K As Long
I = Φύλλα εργασίας ("Φύλλο1").UsedRange.Rows.Count
J = Φύλλα εργασίας ("Φύλλο2").UsedRange.Rows.Count
Αν J = 1 Τότε
Αν Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Τότε J = 0
End If
Ορισμός xRg = Φύλλα εργασίας ("Φύλλο1"). Εύρος ("C1:C" & I)
On Error Συνέχιση Επόμενη
Application.ScreenUpdating = False
Για K = 1 To xRg.Count
Αν CStr(xRg(K).Value) = "Done" Τότε
xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
J = J + 1
End If
Επόμενο
Application.ScreenUpdating = True
Sub End
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σας,

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

Μεταφορά "Μπλε" μετά το "Χρώμα"

A1 = Μπλε
Α5= Χρώμα
A6= (μεταφορά "Μπλε" εδώ)
και ούτω καθεξής...
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αγαπητέ Γιάννη,
Εννοείτε εάν ένα κελί περιέχει "Χρώμα" σε μια στήλη, τότε αντιγράψτε το κείμενο του πρώτου κελιού στο κελί κάτω από το "Χρώμα" και επαναλάβετε την αντιγραφή αυτού του κειμένου μέχρι το τέλος της στήλης;
Δεν υπάρχουν σχόλια δημοσιεύτηκε ακόμα
Τοποθετήστε Περισσότερα
Αφήστε τα σχόλιά σας
Δημοσίευση ως επισκέπτης
×
Αξιολογήστε αυτήν την ανάρτηση:
0   Χαρακτήρες
Προτεινόμενες τοποθεσίες

Ακολουθησε μας

Πνευματικά δικαιώματα © 2009 - www.extendoffice.com. | Ολα τα δικαιώματα διατηρούνται. Τροφοδοτείται από ExtendOffice. | Sitemap
Το Microsoft και το λογότυπο του Office είναι εμπορικά σήματα ή σήματα κατατεθέντα της Microsoft Corporation στις Ηνωμένες Πολιτείες ή / και σε άλλες χώρες.
Προστατεύεται από το Sectigo SSL