[Γενικά] Αντιγραφή.

[bill72]

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

[Spirosgr]

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

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

[bill72]

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

[Spirosgr]

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

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

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

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

[bill72]

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

[Spirosgr]

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

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

[bill72]

Για να γίνω πιο κατανοητός, στον ΚΩΣΤΑ με ΑΜ 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 όπου και υπάρχει το δικό της μοναδικό ΑΜ.

[Spirosgr]

Αντιγράψτε τον κώδικα, σε μια 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

[bill72]

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

[Spirosgr]

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

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

        'Μεταφορά δεδομένων στους προορισμούς τους
        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 μηδενικά (κόκκινο)