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

Πώς να αντιγράψετε σειρές με βάση την τιμή κελιού σε μια στήλη;

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

doc διπλές σειρές ανά κελί 1

Διπλότυπες σειρές πολλές φορές με βάση τις τιμές κελιού με τον κώδικα VBA


βέλος μπλε δεξιά φούσκα Διπλότυπες σειρές πολλές φορές με βάση τις τιμές κελιού με τον κώδικα VBA

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

1. Κρατήστε πατημένο το ALT + F11 για να ανοίξετε το Microsoft Visual Basic για εφαρμογές παράθυρο.

2. Κλίκ Κύριο θέμα > Μονάδα μέτρησηςκαι επικολλήστε τον ακόλουθο κώδικα στο Μονάδα μέτρησης Παράθυρο.

Κωδικός VBA: Διπλότυπες σειρές πολλές φορές με βάση την τιμή κελιού:

Sub CopyData()
'Updateby Extendoffice
    Dim xRow As Long
    Dim VInSertNum As Variant
    xRow = 1
    Application.ScreenUpdating = False
    Do While (Cells(xRow, "A") <> "")
        VInSertNum = Cells(xRow, "D")
        If ((VInSertNum > 1) And IsNumeric(VInSertNum)) Then
           Range(Cells(xRow, "A"), Cells(xRow, "D")).Copy
           Range(Cells(xRow + 1, "A"), Cells(xRow + VInSertNum - 1, "D")).Select
           Selection.Insert Shift:=xlDown
           xRow = xRow + VInSertNum - 1
        End If
        xRow = xRow + 1
    Loop
    Application.ScreenUpdating = False
End Sub

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

Note: Στον παραπάνω κωδικό, το γράμμα A υποδεικνύει τη στήλη έναρξης του εύρους δεδομένων σας και το γράμμα D είναι το γράμμα στήλης στο οποίο θέλετε να αντιγράψετε τις σειρές βάσει. Αλλάξτε τα ανάλογα με τις ανάγκες σας.


Τα καλύτερα εργαλεία παραγωγικότητας του 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% και μειώνει εκατοντάδες κλικ του ποντικιού για εσάς κάθε μέρα!
κάτω μέρος γραφείου
Σχόλια (41)
Δεν υπάρχουν ακόμη βαθμολογίες. Γίνε ο πρώτος που θα αξιολογήσετε!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αυτό λειτούργησε τέλεια. Τι θα προσθέσω στον κώδικά σας για να εξαφανιστούν τυχόν γραμμές με '0'; Το χρησιμοποιούμε για ετικέτες SKU. Ευχαριστώ για την εξαιρετική λύση!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Σ'αγαπώ. Σας ευχαριστώ.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Σας ευχαριστώ! Οι γραμμές 10 και 11 "D" υποδηλώνουν το τέλος της σειράς και αυτό μπορεί να χρειαστεί να αλλάξει στο εύρος δεδομένων σας για να λειτουργήσει.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σας,
Ξέρει κάποιος να μετατρέψει αυτόν τον κώδικα VBA σε σενάρια Εφαρμογών Google (φύλλα Google);
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Χρησιμοποίησα τον παραπάνω κώδικα που λειτουργεί εξαιρετικά, αλλά χρειάζομαι ένα ακόμη βήμα μετά την επικόλληση της σειράς. Απλώς δεν μπορώ να το κάνω να λειτουργήσει σωστά. Το χρειάζομαι για να βάλω το μηδέν στη στήλη "N" στη σειρά μετά την επικόλληση, αλλά να διατηρήσω την τιμή στο "N" στην αρχική αντιγραμμένη σειρά.


Sub CopyData()
'Ενημέρωση Extendoffice 20160922
Dim xRow As Long
Dim VinSertNum As Variant
xRow = 1
Application.ScreenUpdating = False
Do while (Κελιά(xRow, "A") <> "")
VInSertNum = Κελιά(xRow, "J")
Εάν ((VInSertNum > 1) And IsNumeric(VInSertNum)) Τότε
Εύρος (Cells(xRow, "A"), Cells(xRow, "AN")).Αντιγραφή
Κελιά(xRow, 14).Τιμή = 0 αυτό έκανε όλες τις σειρές
Range(Cells(xRow + 1, "A"), Cells(xRow + VInSertNum - 1, "AN")).Επιλέξτε
'Κελιά(xRow, 14).Τιμή = 0
Αυτό έκανε όλες τις σειρές
Επιλογή. Εισαγωγή αλλαγής: = xlDown
Κελιά(xRow, 14).Τιμή = 0 αυτό έκανε μόνο την πρώτη σειρά
xRow = xRow + VInSertNum - 1
'Κελιά(xRow - 1, 14).Τιμή = 0
End If
Κελιά(xRow - 1, 14).Τιμή = 0
xRow = xRow + 1
Κελιά(xRow + 1, 14).Τιμή = 0
Βρόχος
'Cells(xRow, 14).Τιμή = 0 αυτό δεν έκανε σειρές
Application.ScreenUpdating = False
Sub End
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Στιβ, μπορούσες να το κάνεις αυτό; η απαίτησή μου είναι κάπως η ίδια :(
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σας παιδιά,
Ίσως το παρακάτω άρθρο μπορεί να σας βοηθήσει, ελέγξτε το:
https://www.extendoffice.com/documents/excel/3682-excel-copy-and-insert-row-multiple-times.html
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Ξέρετε ποιος θα ήταν ο κώδικας για να αντιγράψετε τη σειρά μόνο μία φορά, με βάση το εάν το κελί d περιέχει "Ναι" - Κυνηγάω παρόμοιο κώδικα, αλλά για κάτι που θα αντιγράψει μια σειρά που βασίζεται σε ένα κελί που λέει ναι
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Χρησιμοποιώ λοιπόν αυτόν τον κωδικό, αλλά θέλω να κάνει αναζήτηση σε ολόκληρο το έγγραφο όχι μόνο στη σειρά 1 ή οτιδήποτε άλλο υποδεικνύεται από το xRow = 1. Προσπαθώ να βάλω στην περιοχή 1:2000 αλλά δεν λειτουργεί. Πώς μπορώ να αναγνωρίσω xRow = οποιαδήποτε σειρά στο φύλλο που περιλαμβάνει τις πληροφορίες που αναγνωρίζω στον παρακάτω κώδικα;


Dim xRow As Long
Dim Value As Variant


xRow = 1: 2000

Application.ScreenUpdating = False
Do while (Κελιά(xRow, "A") <> "")
Τιμή = Κελιά (xRow, "D")
Τιμή2 = Κελιά(xRow, "A")
Αν Όχι ((Τιμή = "αλληλεγγύη γενική") Και είναι Αριθμητική(Τιμή2 = G0202)) Τότε
Εύρος(Κελιά(xRow, "A"), Cells(xRow, "D")).Αντιγραφή
Εύρος (Κελιά(xRow + 1, "A"), Κελιά (xRow + 1, "D")).Επιλέξτε
Επιλογή. Εισαγωγή αλλαγής: = xlDown
xRow = xRow + 1
End If
xRow = xRow + 1
Βρόχος
Application.ScreenUpdating = False
Sub End
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σας, αυτό λειτούργησε τέλεια. Ωστόσο, έχω μια αναφορά με 1000 καταχωρήσεις και ο κωδικός σταμάτησε να αντιγράφεται γύρω από την καταχώριση 480. Υπάρχει κάτι που μπορώ να προσθέσω ώστε να ολοκληρώσει την ενέργεια σε ολόκληρη την αναφορά;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου, Λία,
Έχω δοκιμάσει τον κώδικα σε 2000 σειρές και λειτουργεί καλά.
Θα μπορούσατε να μου στείλετε το φύλλο εργασίας σας για δοκιμή του κώδικα;
Η διεύθυνση email μου είναι skyyang@extendoffice.com
Ανυπομονώ για την απάντηση σας!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γειά σου! Το έβαλα να δουλέψει. Ήταν ένα σφάλμα από την πλευρά μου, η αναφορά είχε μερικές κενές σειρές που ήταν κρυμμένες που έκαναν το σενάριο να σταματήσει να επαναλαμβάνεται. Λειτούργησε για την αναφορά μου με 8,000 σειρές! Ευχαριστώ Q
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σου Leah και Skyyang,
Έχω ένα παρόμοιο πρόβλημα - το σενάριο λειτουργεί καλά σε ένα φύλλο εργασίας περίπου 100 σειρών, αλλά σταματά να λειτουργεί για οτιδήποτε μεγαλύτερο. Έχω ελέγξει για κενές γραμμές στη στήλη από όπου προέρχεται ο αριθμός πολλαπλασιασμού και δεν υπάρχουν. Υπάρχουν άλλοι λόγοι για τους οποίους το σενάριο ενδέχεται να μην λειτουργεί για μεγαλύτερα σύνολα δεδομένων;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Ευχαριστώ! ήταν μια εξαιρετική λύση για όλα μου τα προβλήματα!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Αυτό το σενάριο φαίνεται να είναι ακριβώς αυτό που χρειάζομαι, ωστόσο, όταν το εκτελώ, λαμβάνω ένα σφάλμα στη γραμμή Selection.Insert Shift:=x1Down

Κάποια πρόταση για το πώς να το διορθώσω;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια, για μένα δεν λειτουργεί, θέλω να αφαιρέσω γράμματα και αριθμούς διπλό είναι δυνατό;
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Υπάρχει τρόπος ενημέρωσης της λειτουργικής μονάδας ώστε να αντιγράφονται μόνο νέα δεδομένα; Εργάζομαι σε ένα έγγραφο που βρίσκεται σε εξέλιξη και δεν θέλω ο κώδικας να αντιγράφει δεδομένα που έχουν προηγουμένως αντιγραφεί.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
υπάρχει κάποιος τρόπος να προσθέσουμε σε καθένα επαναλαμβανόμενα κελιά, διαδοχικούς χαρακτήρες; παράδειγμα
ΚΤΕ+0001

ΚΤΕ+0002
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Ωραίος! Σας ευχαριστώ. Αναρωτιέμαι αν θα μπορούσε κάποιος να δώσει μια υπόδειξη για το πώς θα ενσωματώσω μια νέα στήλη πληροφοριών στον πίνακα (στήλη Ε) που είναι ένας αριθμός αυξανόμενης τιμής για κάθε αντιγραμμένη σειρά, 1, 2, 3, 4 κ.λπ... και μετά όταν φτάσει στο επόμενο στοιχείο που θα αντιγραφεί X φορές, θα αρχίσει να αριθμεί ξανά από το 1 και θα αυξάνεται κατά 1 κάθε φορά.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια, το δοκίμασα αυτό, αλλά υπάρχει τρόπος να εξετάσω εάν υπάρχουν πολλά κριτήρια με τα δεδομένα που αντιγράφω
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σας,

Δημιουργώ ένα υπολογιστικό φύλλο χρησιμοποιώντας τον τύπο που παρέχεται αλλά έχω σφάλματα. παρακαλώ μπορεί κάποιος να με ενημερώσει ποια πρέπει να είναι η φόρμουλα μου;

το τραπέζι μου είναι από την AY με τις ποσότητες σε Κ.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια σας, προσπάθησα να προσαρμόσω αυτόν τον κωδικό αλλά αντιμετωπίζω δυσκολίες.
έχω είδη απογραφής. Κάθε στοιχείο είναι δύο σειρές.και θέλετε να αντιγραφούν N αριθμό χρόνου
στο επάνω μέρος του υπολογιστικού φύλλου, έχω ένα κελί ας το ονομάσω A1, πόσες φορές έχει γίνει διπλότυπο; Ν
Όποια και αν είναι η τιμή N, θέλω να αντιγράψω το αρχικό είδος αποθέματος που έχω (A16, A17) πολλές φορές.
οπότε το αντιγραμμένο στοιχείο θα πρέπει να ξεκινά από το A18 (και είναι δύο σειρές, το επόμενο στοιχείο a20 κ.λπ.
Ευχαριστώ
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Γεια, ο κώδικας λειτουργεί τέλεια. Ήθελα επίσης να προσθέσω +1 στην ημερομηνία (μόνο τις καθημερινές) κάθε φορά που η σειρά γίνεται διπλότυπη.
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Σε ευχαριστώ πάρα πολύ! Αυτό μου έχει εξοικονομήσει τόσο πολύ χρόνο που συνήθιζα να σπαταλάω αντιγράφοντας και επικολλώντας όλες τις σειρές δεδομένων μου.
Δύο αντίχειρες πάνω!!
Αυτό το σχόλιο ελαχιστοποιήθηκε από τον συντονιστή του ιστότοπου
Υπέροχο κομμάτι κώδικα!!! Σας ευχαριστώ!!!
Δεν υπάρχουν σχόλια δημοσιεύτηκε ακόμα
Τοποθετήστε Περισσότερα

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

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