Αντιγραφή.
 

Καλησπέρα σας,
Βρήκα ένα πολύ χρήσιμο αρχείο στο forum
http://www.ms-office.gr/forum/excel-...antigrafi.html
και θα χρειαζόμουν την βοήθεια σας στην διαμόρφωση του κώδικα έτσι ώστε τα μητρώα και να δουλεύουν ως έχουν, αλλά να δουλεύουν ταυτόχρονα και με μητρώα που περιέχουν και γράμματα δηλαδή ΕΕ086, του ίδιου πάντα τύπου κείμενο.

Ευχαριστώ εκ των πρότερων.

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 String
iVL = Sheet5.Range("a" & i).Text
On Error Resume Next
If iVL = 0 Then
GoTo Blnc_Exect:
Else
GoTo Nrml_Exect:
End If
Nrml_Exect:

'Ψάχνει κοινούς ΑΜ στα φύλλα προορισμού
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).NumberFormat = "@"
Sheets("NotExists").Range("a" & Nr).Value = Format(iVL, "000000")

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.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
Sheet1.Range("Q" & Mtch1 + handicap1or3).Value = Sheet5.Range("S" & 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
Sheet3.Range("Q" & Mtch3 + handicap1or3).Value = Sheet5.Range("S" & i).Value
End If
Blnc_Exect:

Next i
End Sub

Καλημέρα
Έγινε προσαρμογή στον κώδικα ώστε:

Στο φύλλο «Αφετηρία», οι ΑΜ να είναι μορφής:
Κείμενο ως Αριθμός = 100 ή
Κείμενο ως Αριθμός με μηδέν μπροστά = 00123 αλλά και
Καθαρό Κείμενο (string) = ΕΕ200

Η μορφοποίηση στις στήλες των ΑΜ, στα φύλλα, θα πρέπει να είναι «Κείμενο».

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

*Όπως και στο αρχικό ζητούμενο, η γραμμή τίτλων στα φύλλα «Προορισμοί»
είναι ίδια και στα δύο φύλλα.

Σημείωση
Ο κώδικας, δεν προβλέπει καθαρισμό των περιοχών προορισμού.
Αν θέλετε να υπάρχει, προσαρμόστε στην αρχή του κώδικα κάτι σαν:
Sh1.Range("Περιοχή").ClearContents και για τα δύο φύλλα προορισμού (Sh1 & Sh2)

Δουλεύει ακριβώς όπως το ήθελα σ ’ευχαριστώ πολύ, καλή συνέχεια .

Καλημέρα, καλή συνέχεια.

Άθροιση και αντιγραφή.
 

Καλησπέρα,
Επανέρχομαι στο θέμα λόγω μιας αλλαγής που έγινε στην εργασία μου και είναι η εξής:
Οι Στήλες S+Y+AF+AN του φύλλου Αφετηρία να αθροίζονται όπου υπάρχουν δεδομένα και να αντιγράφεται το σύνολο στην στήλη O στο φύλλο προορισμός.
Στο παράδειγμα ΑρΜητρώου 100 = 10 και 200 = 8
Ευχαριστώ πολύ εκ των προτέρων,

Καλημέρα
Στο κάτω μέρος του κώδικα, εκεί που λέει:
'Μεταφορά δεδομένων στους προορισμούς τους
Στο πρώτο τμήμα (If Mtch1 <> 0 Then)
βάλε πριν το End If
Στο δεύτερο τμήμα (If Mtch2 <> 0 Then)
βάλε πριν το End If
(*βλέπε εικόνα)

Γιατί έγραψα τον κώδικα με αυτόν τον τρόπο:

Αν αλλάξεις τη στήλη προορισμού (ο) αθροίσματος,
μπορείς εύκολα να το αλλάξεις
ακόμα κι αν η αλλαγή, αφορά το ένα μόνο φύλλο προορισμού.

Αν χρειαστεί να μεταβάλεις μια στήλη που θα αθροιστεί (s, y, af, an),
μπορείς εύκολα να το αλλάξεις
ακόμα κι αν η αλλαγή αφορά το ένα μόνο φύλλο προορισμού.
Παράδειγμα, αλλάζω την y με z στο φύλλο Προορισμός_1 και μόνο.
Αν χρειαστεί να προσθέσεις μια στήλη στο άθροισμα,
προσθέτεις μια γραμμή:
για το ανάλογο φύλλο προορισμού.

Σημείωση 1:
Το μεταφερόμενο άθροισμα, έχει μορφή «Γενική»
Αν θέλεις άλλη μορφοποίηση, πες μου να το διορθώσουμε.

Σημείωση 2:
Αν το μεταφερόμενο άθροισμα, είναι μηδέν (πχ από κενά κελιά),
θα γράψει μηδέν (0)
Αν θέλεις να γράφει-αφήνει «κενό», πες μου να το διορθώσουμε.

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

Το αρχικό ζητούμενο, δεν έχει καμία σχέση με το τελευταίο αρχείο.

Στο βιβλίο που ανέβασες, δεν υπάρχει προορισμός_2, υπάρχουν συγχωνευμένα κελιά
(μεγάλο πρόβλημα στους κώδικες)
και διόρθωση του κώδικα, με ότι νόμιζες ότι πρέπει να καταργηθεί...

Από την στιγμή που καταργείς τον προορισμό_2, αυτό:
δεν παίζει...
Πρέπει να καταργηθούν και κάποιες άλλες γραμμές και μεταβλητές και να γίνει:
Αυτό δεν σημαίνει ότι όλα θα πάνε καλά...

Το βιβλίο που ανεβάζω, (Book1) είναι το αρχικό ζητούμενο συν τα αθροίσματα.
Όλα πάνε καλά...

Το βιβλίο σου το τελευταίο, (Book2), με κάποιες διορθώσεις, σε 'μένα δουλεύει.

Τώρα...
αν δεν σου δίνει εσένα αποτέλεσμα, θα πρέπει να βάλεις αντί κενά
(στα κελιά που θα αθροιστούν) μηδενικά.

Αν το ζητούμενο από την αρχή ήταν το τελευταίο, θα έγραφα άλλο κώδικα
παρόμοιο μεν αλλά και με κάποιους ελέγχους...αλλάζοντας και το layout.

Καλημέρα Σπύρο,
Δουλεύει και σε μένα μια χαρά τώρα, το μόνο που θα ήθελα ακόμη αν σου είναι εύκολο είναι ότι αν το μεταφερόμενο άθροισμα είναι 0 να αφήνει κενό.

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

Εφ όσον ο κώδικας, δεν καθαρίζει αυτόματα περιοχές (προορισμού),
ενδέχεται να προκύψουν σφάλματα.

Η μορφοποίηση των μεταφερόμενων αριθμών,
είναι ίδια με την μορφοποίηση της αφετηρίας (0,00)

Η μορφοποίηση των αθροισμάτων,
είναι ίδια με την μορφοποίηση της αφετηρίας (0,00)