Forum - Γενικά Αντιγραφή.

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

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

- - [Γενικά] Αντιγραφή. (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/4418-antigrafi.html)

Αντιγραφή.

Καλημέρα σε όλους .
Για μία ακόμη φορά θα χρειαστώ την βοήθεια σας γιατί οι γνώσεις μου δεν επαρκούν να λύσω το πρόβλημα όσο και αν παιδεύτηκα.
Στο δείγμα που ανεβάζω χρειάζομαι από το φύλλο 5 οι στήλες 1 έως 6 να αντιγράφονται στα φύλλα 1 και 3 κατά ΑΜ, τα μισά ονόματα βρίσκονται στο φύλλο 1 και κάποια άλλα στο φύλλο 3 και όλα στο φύλλο 5 δεν είναι πάντα ταξινομημένα και στα τρία φύλλα, όμως το πεδίο ΑΜ είναι απόλυτο για κάθε εργαζόμενο.
Το δείγμα είναι φτιαγμένο σε πραγματικές συνθήκες εργασίας σας ευχαριστώ πολύ.

Καλημέρα
Βασίλη...
Πρώτον, με ποιό κριτήριο θα πάνε, άλλα ονόματα στο 1 και άλλα στο 3;
Δεύτερον, Θέλεις οι στήλες 1-6 να μεταφερθούν...από το 5 στα 1-3
Ακόμα κι αν το κριτήριο υπήρχε, τι να μεταφερθει για παράδειγμα στην στήλη C (3) του 1 όταν οι
στήλες B-D (2-4_ του 5 είναι συγχωνευμένες...

Με αυτό το «στήσημο», ακόμα κι αν βρεθεί μαγικός τρόπος λύσης, θα έχεις μόνιμα προβλήματα...

Γειά σου Σπύρο
Τα ονόματα υπάρχουν ήδη στα φύλλα 1,3,5, κάποια είναι στο 1 άλλα στο 3 και όλα μαζί στο 5. Το κριτήριο για την μεταφορά τον στοιχείων είναι το ΑΜ που είναι μοναδικό σε κάθε όνομα . Τα στοιχεία που πρέπει να μεταφερθούν είναι στο φύλλο 5 από το κελί H11 έως O11 και κάτω. Το γνωρίζω ότι ίσως είναι αδύνατο να γίνει γι’ αυτό και ζήτησα την βοήθεια σας αν υπάρχει κάποιος τρόπος ,γιατί κάθε μήνα τα περνάω χειροκίνητα και είναι πάρα πολλά.
Το στήσιμο δεν είναι δικό μου είναι αρχεία που εξάγονται από λογισμικό γι’ αυτό και δεν μπορώ να το πειράξω.

Αν απαντήσω στο ερώτημά σου,
θα πρέπει αυτό που θα σου πω να είναι υπεύθυνο και σωστό...

Να σου πω μια τυχαία απάντηση, (αν υπάρχει)
και σε λίγο να μην δουλεύει, δεν το θεωρώ σωστό...

Οκ μου λες το κριτήριο, ο ΑΜ...
ΑΜ έχουν όλα τα ονόματα.
Ποιά λοιπόν θα πάνε που...
Αυτό το κριτήριο πρέπει να μας πεις.

Θα επαναλάβω όμως, ότι δεν μπορεί να αντιγραφεί η C στήλη γιατί είναι
ενσωματωμένη-συγχωνευμένη με την Β-D...

Σπύρο κατ’ αρχήν σε ευχαριστώ πολύ για το ενδιαφέρων σου να με βοηθήσεις.
Το ΑΜ είναι μοναδικό όπου υπάρχει κοινό ΑΜ από το 5 στο 1-3 να μεταφέρονται τα στοιχεία από τις στήλες H11 έως O11 και κάτω του 5, ακριβώς στο αντίστοιχο ΑΜ του 1-3 στις στήλες U9 έως Z9 δεν χρειάζομαι να μεταφέρεται καμία άλλη στήλη γιατί θα δημιουργήσει πρόβλημα.

Συγνώμη Βασίλη...δεν βγάζω άκρη...

«χρειάζομαι από το φύλλο 5 οι στήλες 1 έως 6 να αντιγράφονται στα φύλλα 1 και 3 κατά ΑΜ»

Για να γίνω πιο κατανοητός, στον ΚΩΣΤΑ με ΑΜ 108152 να αντιγραφούν οι τιμές από το φύλλο 5
50,00 15,00 62,00 11,00 5,00 1,00 στο φύλλο 1 όπου υπάρχει το συγκεκριμένο ΑΜ στις στήλες U9 έως Z9, και αντίστοιχα η
ΚΑΤΕΡΙΝΑ με ΑΜ 107956 οι τιμές 16,00 144,00 12,00 32,00 56,00 75,00 να αντιγραφούν στο φύλλο 3 όπου και υπάρχει το δικό της μοναδικό ΑΜ.

Αντιγράψτε τον κώδικα, σε μια module.
Αν η έκφραση "Option Explicit" υπάρχει ήδη να μην την αντιγράψετε δεύτερη φορά.
Χρησιμοποιήθηκαν, οι κωδικές ονομασίες φύλλων (πχ Sheet1)
Ο κώδικας προσαρμόστηκε, για να μην επιρεάζεται από συγχωνευμένα κελιά.

Αν υπάρξουν ΑΜ στο φύλλο 5,
που δεν υπάρχουν στα 1 και 3,
«μαζεύονται» σε νέο φύλλο,
με όνομα "NotExists" που δημιουργεί ο κώδικας,
στο τέλος των υφιστάμενων φύλλων του βιβλίου.

Το βιβλίο, πρέπει να είναι σε μορφές .xls - .xlsm - .xlsb για να μπορεί να εκτελέσει κώδικα.

Κώδικας:

Option Explicit
 Const handicap5 As Byte = 11    'Επάνω κενές σειρές φύλλου 5
 Const handicap1or3 As Byte = 8    'Επάνω κενές σειρές φύλλων 2 και 3
 
 '---------------------------------------------------------------------------
 

Sub transfer()

    Application.ScreenUpdating = False
 

    'Διαγράφει φύλλο με όνομα NotExists (Αν Υπάρχει)

    Dim WSH As Worksheet

    Application.DisplayAlerts = False

    For Each WSH In ThisWorkbook.Worksheets

        If WSH.Name = "NotExists" Then WSH.Delete

    Next WSH

    Application.DisplayAlerts = True
 

    'Βάζει νέο φύλλο με όνομα NotExists (1α)

    Dim ws As Worksheet

    Set ws = ThisWorkbook.Sheets.Add(After:= _

                                     ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))

    ws.Name = "NotExists"

    ws.Range("a1").Value = "ΑΜ που δεν υπάρχουν"
 

    'Σετάρισμα & καθαρισμός περιοχών

    '1. Αφετηρία

    Dim Lr5 As Long

    Lr5 = Sheet5.Cells(Rows.Count, 1).End(xlUp).Row
 

    '2. Προορισμοί

    Dim Lr1 As Long

    Lr1 = Sheet1.Cells(Rows.Count, 2).End(xlUp).Row
 

    Sheet1.Range("u9:z" & Lr1).ClearContents
 

    Dim Lr3 As Long

    Lr3 = Sheet3.Cells(Rows.Count, 2).End(xlUp).Row
 

    Sheet3.Range("u9:z" & Lr1).ClearContents
 

    Dim Rng1 As Range, Rng3 As Range

    Set Rng1 = Sheet1.Range("b9:b" & Lr1)

    Set Rng3 = Sheet3.Range("b9:b" & Lr3)
 

    Dim i As Long

    For i = handicap5 To Lr5
 

        Dim iVL As Double

        iVL = Val(Sheet5.Range("a" & i).Value)
 

        'Ψάχνει κοινούς ΑΜ στα φύλλα προορισμού

        Dim Mtch1 As Long, Mtch3 As Long

        On Error Resume Next

        Mtch1 = 0

        Mtch1 = Application.WorksheetFunction.Match(iVL, Rng1, 0)

        Mtch3 = 0

        Mtch3 = Application.WorksheetFunction.Match(iVL, Rng3, 0)
 

        'Αν βρεθεί ΑΜ χωρίς προορισμό (1β)

        If Mtch1 = 0 And Mtch3 = 0 Then
 

            'Τοποθετείται στο νέο φύλλο (μαζί με ημερομηνία = σήμερα)

            Dim Nr As Long

            Nr = Sheets("NotExists").Cells(Rows.Count, 1).End(xlUp).Row + 1
 

            Sheets("NotExists").Range("a" & Nr).Format = "@"

            Sheets("NotExists").Range("a" & Nr).Value = iVL

            Sheets("NotExists").Range("b" & Nr).Value = Format(Date, "dd/mmm/yyyy")
 

            With Sheets("NotExists").Columns("a:b")

                .WrapText = False

                .ShrinkToFit = False

                .MergeCells = False

                .EntireColumn.AutoFit

            End With

        End If
 

        'Μεταφορά δεδομένων στους προορισμούς τους

        If Mtch1 <> 0 Then

            Sheet1.Cells(Mtch1 + handicap1or3, 21).Value = Sheet5.Range("h" & i).Value

            Sheet1.Cells(Mtch1 + handicap1or3, 22).Value = Sheet5.Range("i" & i).Value

            Sheet1.Cells(Mtch1 + handicap1or3, 23).Value = Sheet5.Range("j" & i).Value

            Sheet1.Cells(Mtch1 + handicap1or3, 24).Value = Sheet5.Range("k" & i).Value

            Sheet1.Cells(Mtch1 + handicap1or3, 25).Value = Sheet5.Range("m" & i).Value

            Sheet1.Cells(Mtch1 + handicap1or3, 26).Value = Sheet5.Range("o" & i).Value

        End If
 

        If Mtch3 <> 0 Then

            Sheet3.Cells(Mtch3 + handicap1or3, 21).Value = Sheet5.Range("h" & i).Value

            Sheet3.Cells(Mtch3 + handicap1or3, 22).Value = Sheet5.Range("i" & i).Value

            Sheet3.Cells(Mtch3 + handicap1or3, 23).Value = Sheet5.Range("j" & i).Value

            Sheet3.Cells(Mtch3 + handicap1or3, 24).Value = Sheet5.Range("k" & i).Value

            Sheet3.Cells(Mtch3 + handicap1or3, 25).Value = Sheet5.Range("m" & i).Value

            Sheet3.Cells(Mtch3 + handicap1or3, 26).Value = Sheet5.Range("o" & i).Value

        End If
 

    Next i

End Sub

Καλημέρα Σπύρο,
Έκανα δοκιμές όλο το βράδυ μέχρι τις πρώτες πρωινές ώρες για να το τεστάρω σε πραγματικές συνθήκες ,ομολογουμένως όταν ζήτησα βοήθεια δεν πίστευα ότι θα ήταν εφικτό κάτι τέτοιο.
Για κάποιο λόγω που δεν καταλαβαίνω μόνο στο Sheet3 στο πραγματικό φύλλο εργασίας μου βγάζει κάποιο σφάλμα συγχώνευσης που όμως με την Αναίρεση συγχώνευσης κελιών U – Z το προσπερνάει και αφού κάνω την δουλειά μου τα συγχωνεύω ξανά.
Το φύλλο NotExists που δημιουργείται ομολογούμενος είναι πολύ χρήσιμο.
Ήθελα να ρωτήσω αν γίνεται, επειδή υπάρχουν πολλές κενές εγγραφές στο φύλλο 5 το NotExists να τις παραβλέπει γιατί μου φέρνει πολλές εγγραφές 0 ΑΜ , και κάτι κουτό ίσως ενώ η μορφοποίηση των ΑΜ σε όλα τα φύλλα είναι κείμενο για να κρατάει τα μηδενικά που προηγούνται του αριθμού στα φύλλα 1-3 μπροστά από το 0 μου βάζει μια απόστροφο ενώ στο 5 δεν βάζει με αποτέλεσμα κάποια ΑΜ να μην τα βλέπει.

Θέμα πρώτο, πρόβλημα με συγχωνευμένα.

Άλλαξε τα τελευταία τμήματα με:

Κώδικας:

        'Μεταφορά δεδομένων στους προορισμούς τους

        If Mtch1 <> 0 Then

            Sheet1.Range("u" & Mtch1 + handicap1or3).Value = Sheet5.Range("h" & i).Value

            Sheet1.Range("v" & Mtch1 + handicap1or3).Value = Sheet5.Range("i" & i).Value

            Sheet1.Range("w" & Mtch1 + handicap1or3).Value = Sheet5.Range("j" & i).Value

            Sheet1.Range("x" & Mtch1 + handicap1or3).Value = Sheet5.Range("k" & i).Value

            Sheet1.Range("y" & Mtch1 + handicap1or3).Value = Sheet5.Range("m" & i).Value

            Sheet1.Range("z" & Mtch1 + handicap1or3).Value = Sheet5.Range("o" & i).Value

        End If
 

        If Mtch3 <> 0 Then

            Sheet3.Range("u" & Mtch3 + handicap1or3).Value = Sheet5.Range("h" & i).Value

            Sheet3.Range("v" & Mtch3 + handicap1or3).Value = Sheet5.Range("i" & i).Value

            Sheet3.Range("w" & Mtch3 + handicap1or3).Value = Sheet5.Range("j" & i).Value

            Sheet3.Range("x" & Mtch3 + handicap1or3).Value = Sheet5.Range("k" & i).Value

            Sheet3.Range("y" & Mtch3 + handicap1or3).Value = Sheet5.Range("m" & i).Value

            Sheet3.Range("z" & Mtch3 + handicap1or3).Value = Sheet5.Range("o" & i).Value

        End If

Θέμα δεύτερο, πρόβλημα με κενά ΑΜ.

Ανάμεσα στις γραμμές με μπλε, βάλε:

Κώδικας:

        Dim iVL As Double

        iVL = Val(Sheet5.Range("a" & i).Value)
 

        On Error Resume Next

        If iVL = 0 Then

            GoTo Blnc_Exect:

        Else

            GoTo Nrml_Exect:

        End If

Nrml_Exect:
 

        'Ψάχνει κοινούς ΑΜ στα φύλλα προορισμού

και κάτω-κάτω, αμέσως πριν το Next i, βάλε:

Κώδικας:

Blnc_Exect:

Θέμα τρίτο, μορφοποίηση ΑΜ κείμενο.

Άλλαξε τις γραμμές:

Κώδικας:

            Sheets("NotExists").Range("a" & Nr).NumberFormat = "@"

            Sheets("NotExists").Range("a" & Nr).Value = Format(iVL, "000000")

Σημείωση:

Οι ΑΜ βλέπω έχουν 6 χαρακτήρες.
Αυτός είναι ο λόγος που υπάρχουν 6 μηδενικά (κόκκινο)