Forum - VBA Αντιγραφή κελιών όταν πληρούν συγκεκριμένα κριτήρια

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

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

- - [VBA] Αντιγραφή κελιών όταν πληρούν συγκεκριμένα κριτήρια (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/4364-antigrafi-kelion-otan-pliroin-sygkekrimena-kritiria.html)

Αντιγραφή κελιών όταν πληρούν συγκεκριμένα κριτήρια

Καλημέρα σε όλους ,

Χρειάζομαι εκ νέου την βοήθεια σας στο εξής πρόβλημα που αντιμετωπίζω ,
Θέλω να κάνω αντιγραφή δεδομένων με κώδικα , από το φύλλο data στο φύλλο data year στις στήλες που έχουν μόνο τιμές και όχι σύνολα (να λάβετε υπόψιν σας ότι τα δεδομένα στο dada ενημερώνονται αυτόματα από άλλα φύλλα) .Επίσης να πληρούν τα εξής κριτήρια , τον τίτλο,το έτος και τον μήνα .Στο φύλλο test αναφέρω πως θα ΄θελα να καταλήξω μετά την αντιγραφή.

Σας ευχαριστώ εκ των προτέρων

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

Στο παράδειγμά σου, οι επικεφαλίδες του data (company 1 - 2016 - 10M) και (company 2 - 2016 - 10M) έπεσαν στις αντίστοιχες επικεφαλίδες του data Year.
Επομένως, αν υπήρχαν δεδομένα στις (company 1 - 2016 - Oct) και (company 2 - 2016 - Oct) δεν θα γινόταν επικόλληση γιατί δεν υπάρχουν όμοιες επικεφαλίδες στο data Year.

Σωστά;

Υ.Γ. Πάντως μπορείς να αποφύγεις τον κώδικα, χρησιμοποιώντας στα κελιά τιμών του data Year την παρακάτω συνάρτηση πίνακα:
Στο κελί M14 γράψε:
=INDEX(dara!$E14:$O14;MATCH(M$3&M$4&M$5;dara!$E$3: $O$3&dara!$E$4:$O$4&dara!$E$5:$O$5;0)) ((Προσοχή: δεν θα πατήσεις Enter αλλά Ctrl+Shift+Enter)
Μετά απλά κάνεις αντιγραφή και επικόλληση τύπων σε όσα κελιά θέλεις να πάρεις την αντίστοιχη τιμή από το φύλλο dara.

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

Ευχαριστώ

Αν τα μεταβλητά κελιά στο Data Year (όχι αυτά με τα σύνολα) περιέχουν την παραπάνω συνάρτηση, τότε θα συμπληρώνονται μόνα τους χωρίς κανένα πρόβλημα. Ακόμα και νέες εταιρείες να προσθέτεις στο Data (νέες στήλες δηλαδή) δεν έχεις κάποιο πρόβλημα, αρκεί οι νέες στήλες να προστίθενται πριν τη στήλη Ο (αν και αυτό διορθώνεται αυξάνοντας το εύρος).

Με λίγα λόγια, κανένα κελί στο Data Year δεν πρέπει να είναι κενό:
Τα κελιά με τα σύνολα θα έχουν κανονικά τη συνάρτηση SUM() και τα υπόλοιπα κελιά που θέλεις να συμπληρώνονται μόνα τους θα πρέπει να περιέχουν την παραπάνω συνάρτηση. Δηλαδή όταν προσθέτεις νέες στήλες στο Data Year (αντιγραφή/επικόλληση μαζί με τις αντίστοιχες συναρτήσεις), τα κελιά θα είναι συμπληρωμένα με τις πρέπουσες συναρτήσεις και κάθε φορά που θα αλλάζεις στοιχεία στο Data, τότε το Data Year θα συμπληρώνεται αυτόματα.

Το δοκίμασα και λειτουργεί.

Ίσως να μην σου έδωσα να καταλάβεις.
Το φύλλο που μεταβάλλονται τα δεδομένα είναι το data (στήλες G & I) , πχ τον 11Μ θα ενημερωθεί με νέα δεδομένα από άλλα φύλλα και τα στοιχεία του 10Μ δεν θα υπάρχουν πουθενά για να τα φέρει στο φύλλο Dada Year στον μήνα που θέλω .Για κάθε μήνα δημιουργώ και άλλο φύλλο εργασίας.

Το βιβλίο, πρέπει να γίνει .xlsm

Το φύλλο dara μετονομάστηκε Data.
Το φύλλο data Year μετονομάστηκε Data_Year.

Θεωρούμε ότι:
Το Data, δεν αλλάζει δομή αλλά δεδομένα κάθε μήνα.
Το Data_Year δεν αλλάζει δομή αλλά προστίθενται στήλες, κάθε μήνα.
Τα φύλλα, δεν θα αλλάξουν όνομα, ποτέ.

Βάζουμε στο e2 του Data: =E3&E4&E5 και τραβάμε δεξιά, μέχρι στήλη o.
Βάζουμε στο g2 του Data_Year: =G3&G4&G5 και τραβάμε δεξιά, όσο χρειάζεται.

Σε μια module, αντιγράφουμε τον κώδικα:

Κώδικας:

Sub transfer()
 

    Application.ScreenUpdating = False

    If ActiveSheet.Name <> "Data_Year" Then Sheets("Data_Year").Activate
 

    Dim lcol1 As Long
 

    lcol1 = Sheets("Data_Year").Cells(2, Columns.Count).End(xlToLeft).Column
 

    Dim Rng As Range

    Set Rng = Sheets("Data_Year").Range(Cells(2, 7), Cells(2, lcol1))
 

    Dim i As Long, comb As String, mtch As Long

    i = 0

    For i = 5 To 9

        comb = Sheets("Data").Cells(2, i)

        If comb <> "" Then

            On Error Resume Next

            mtch = Application.WorksheetFunction.Match(comb, Rng, 0) + 6
 

            If mtch <> 0 Then
 

                Dim c As Byte

                For c = 7 To 49
 

                    If Sheets("Data").Cells(c, i).Value <> "" Then

                        If Not Sheets("Data_Year").Cells(c, mtch).HasFormula Then

                            Sheets("Data_Year").Cells(c, mtch).Value = Sheets("Data").Cells(c, i).Value

                        End If

                    End If
 

                Next c

            End If

        End If

    Next i
 

End Sub

1
Ο κώδικας, θα μεταφέρει στην κατάλληλη στήλη, τις τιμές από το Data.
2
Δεν αντιγράφονται κενά κελιά.
3
Δεν μεταβάλλονται, οι τύποι στο Data_Year.

Καλησπέρα και ευχαριστώ πολύ

Λειτουργεί άψογα .
θέλω να ρωτήσω αν μπορώ πριν αρχίσει η εκτέλεση του κώδικα να βγάζει ένα μήνυμα " Να ξεκινήσει η αντιγραφή "

Ακριβώς, κάτω από τον τίτλο:
Sub transfer()
Βάλε:
MsgBox "Να ξεκινήσει η αντιγραφή"

Όμως δεν θεωρώ, ότι είναι χρήσιμο, ούτε σαν «εφέ»...

Καλύτερα να βάλεις:

Κώδικας:

Sub transfer()

    Select Case MsgBox("Να ξεκινήσει η αντιγραφή;", vbYesNo, "Εκτέλεση:")
 

    Case vbYes

    

      'Ο κώδικας εδώ
 

    Case vbNo
 

    End Select

End Sub

Το οποίο, δίνει και την δυνατότητα αναίρεσης εκτέλεσης εντολής...

Γενικά, αν δεν υπάρχει ανάγκη προστασίας του χρήστη, μην βάζετε μηνύματα ...

Σε ευχαριστώ και πάλι.

Να 'σαι καλά!