[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