[VBA] Αντιγραφή.

[kosta]

Καλησπέρα σας,
Βρήκα ένα πολύ χρήσιμο αρχείο στο 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

[Spirosgr]

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

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

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

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

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

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

[kosta]

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

[Spirosgr]

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

[kosta]

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

[Spirosgr]

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

            Sh1.Range("o" & Mtch1 + handicap_2_3).Value = _
            Sh0.Range("s" & i).Value + _
            Sh0.Range("y" & i).Value + _
            Sh0.Range("af" & i).Value + _
            Sh0.Range("an" & i).Value

Στο δεύτερο τμήμα (If Mtch2 <> 0 Then)
βάλε πριν το End If

            Sh2.Range("o" & Mtch2 + handicap_2_3).Value = _
            Sh0.Range("s" & i).Value + _
            Sh0.Range("y" & i).Value + _
            Sh0.Range("af" & i).Value + _
            Sh0.Range("an" & i).Value

(*βλέπε εικόνα)

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

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

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

Sh0.Range("y" & i).Value + _ θα γίνει Sh0.Range("z" & i).Value + _

Αν χρειαστεί να προσθέσεις μια στήλη στο άθροισμα,
προσθέτεις μια γραμμή:

Sh0.Range("Γραμμα Στήλης" & i).Value + _

για το ανάλογο φύλλο προορισμού.

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

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

[kosta]

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

[Spirosgr]

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

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

Από την στιγμή που καταργείς τον προορισμό_2, αυτό:

If Mtch1 = 0 And Mtch2 = 0 Then

δεν παίζει...
Πρέπει να καταργηθούν και κάποιες άλλες γραμμές και μεταβλητές και να γίνει:

If Mtch1 = 0 Then

Αυτό δεν σημαίνει ότι όλα θα πάνε καλά...

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

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

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

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

[kosta]

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

[Spirosgr]

Αντικαθιστούμε οποιονδήποτε παλαιότερο κώδικα, με αυτόν:

Const startHandicap As Byte = 8   'Γραμμή τίτλων στο φύλλο Αφετηρία
Const destHandicap  As Byte = 7    'Γραμμή τίτλων στον Προορισμό
Const destTitle     As String = "ΑΜ που δεν περάστηκαν"    'Τίτλος Προορισμού
Const WSHName       As String = "NotExists"  'Όνομα φύλλου ελέγχου

Sub TransferPlusSumData()
    Dim WSH         As Worksheet
    Dim Rng1        As Range
    Dim LrowStart   As Long
    Dim LrowDest    As Long
    Dim i           As Long
    Dim Mtch        As Long
    Dim iVL         As Variant

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    'Διαγράφει φύλλο με όνομα NotExists (Αν Υπάρχει)
    For Each WSH In ThisWorkbook.Worksheets
        If WSH.Name = WSHName Then WSH.Delete
    Next WSH

    Application.DisplayAlerts = True

    'Βάζει νέο φύλλο με όνομα NotExists
    Set WSH = ThisWorkbook.Sheets.Add _
              (After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    WSH.Name = WSHName
    WSH.Range("a1").Value = destTitle

    'Σετάρισμα & καθαρισμός περιοχών
    '1. Αφετηρία
    LrowStart = Sh0.Cells(Rows.Count, 1).End(xlUp).Row

    '2. Προορισμός
    LrowDest = sh1.Cells(Rows.Count, 2).End(xlUp).Row
    Set Rng1 = sh1.Range("b" & destHandicap + 1 & ":b" & LrowDest)

    For i = startHandicap + 1 To LrowStart
        iVL = Sh0.Range("a" & i).Value
        On Error Resume Next
        If iVL = 0 Then
            GoTo Blnc_Exect:
        Else
            GoTo Nrml_Exect:
        End If
Nrml_Exect:

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

        On Error Resume Next
        Mtch = 0
        Mtch = Application.WorksheetFunction.Match(iVL, Rng1, 0)

        'Αν βρεθεί ΑΜ χωρίς προορισμό
        If Mtch = 0 Then

            'Τοποθετείται στο νέο φύλλο (μαζί με ημερομηνία = σήμερα)
            Dim Nr  As Long
            Nr = Sheets(WSHName).Cells(Rows.Count, 1).End(xlUp).Row + 1

            Sheets(WSHName).Range("a" & Nr).NumberFormat = "@"
            Sheets(WSHName).Range("a" & Nr).Value = Format(iVL, "@")

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

            With Sheets(WSHName).Columns("a:b")
                .WrapText = False
                .ShrinkToFit = False
                .MergeCells = False
                .EntireColumn.AutoFit
            End With
        End If

        'Μεταφορά δεδομένων στον προορισμό
        If Mtch <> 0 Then
            With sh1
                .Range("t" & Mtch + destHandicap).NumberFormat = "0.00"
                .Range("t" & Mtch + destHandicap).Value = Sh0.Range("k" & i).Value
                .Range("u" & Mtch + destHandicap).NumberFormat = "0.00"
                .Range("u" & Mtch + destHandicap).Value = Sh0.Range("m" & i).Value
                .Range("w" & Mtch + destHandicap).NumberFormat = "0.00"
                .Range("w" & Mtch + destHandicap).Value = Sh0.Range("o" & i).Value
                .Range("p" & Mtch + destHandicap).NumberFormat = "0.00"
                .Range("p" & Mtch + destHandicap).Value = Sh0.Range("t" & i).Value
                .Range("q" & Mtch + destHandicap).NumberFormat = "0.00"
                .Range("q" & Mtch + destHandicap).Value = Sh0.Range("aa" & i).Value
                .Range("r" & Mtch + destHandicap).NumberFormat = "0.00"
                .Range("r" & Mtch + destHandicap).Value = Sh0.Range("ag" & i).Value
                .Range("s" & Mtch + destHandicap).NumberFormat = "0.00"
                .Range("s" & Mtch + destHandicap).Value = Sh0.Range("ao" & i).Value
            End With

            'Πρόσθεση κελιών (στηλών που ορίζουμε)
            Dim Data_S As Double
            Dim Data_Y As Double
            Dim Data_AF As Double
            Dim Data_AN As Double

            With Sh0
                Data_S = .Range("s" & i).Value
                Data_Y = .Range("y" & i).Value
                Data_AF = .Range("af" & i).Value
                Data_AN = .Range("an" & i).Value
            End With

            Dim SumData As Double
            SumData = Application.WorksheetFunction.Sum(Data_S, Data_Y, Data_AF, Data_AN)

            With sh1
                If SumData = 0 Then
                    .Range("o" & Mtch + destHandicap).Value = vbNullString
                Else
                    .Range("o" & Mtch + destHandicap).NumberFormat = "0.00"
                    .Range("o" & Mtch + destHandicap).Value = SumData
                End If
            End With
        End If
Blnc_Exect:
    Next i
End Sub

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

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

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

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