DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub ulkeye_aktar()
Dim sh As Worksheet, ay As String, syf As Worksheet
Dim sut As Byte, k As Range, i As Long, j As Byte
Sheets("anasayfa").Select
If Range("G3").Value = "" Then
MsgBox "ÜLKEYE Bir ülke ismi girmeleisiniz.", vbCritical, "UYARI"
Range("G3").Select
Exit Sub
End If
If Range("G4").Value = "" Then
MsgBox "Bir Ay adı girmelisiniz", vbCritical, "UYARI"
Range("G4").Select
Exit Sub
End If
Application.ScreenUpdating = False
Set sh = Sheets(UCase(Replace(Replace(Range("G3").Value, "ı", "I"), "i", "İ")))
ay = UCase(Replace(Replace(Range("G4").Value, "ı", "I"), "i", "İ"))
For i = 2 To Cells(65536, "A").End(xlUp).Row
For Each syf In Worksheets
If UCase(Replace(Replace(syf.Name, "ı", "I"), "i", "İ")) = sh.Name Then
Set k = sh.Range("A2:A65536").Find(Cells(i, "A").Value, , xlValues, xlWhole)
For j = 2 To 13
If UCase(Replace(Replace(syf.Cells(1, j).Value, "ı", "I"), "i", "İ")) = ay Then
sut = j
Exit For
End If
Next j
If k Is Nothing Then
sat = sh.Cells(65536, "A").End(xlUp).Row + 1
If sat >= 65533 Then
MsgBox Cells(i, "A").Value & vbLf & Range("G3").Value & _
"Sayfasına Yeni Kayıt yapılamdı.Satır doldu"
Exit For
End If
sh.Cells(sat, "A").Value = Cells(i, "A").Value
Else
If sh.Cells(k.Row, sut).Value > 0 Then
Exit For
Else
sat = k.Row
End If
End If
sh.Cells(sat, sut).Value = Cells(i, "B").Value
End If
Next
Next
Application.ScreenUpdating = True
MsgBox "İşlem Tamamdır.", vbOKOnly + vbInformation, "EVREN"
End Sub