Sub YeniKayýt()
Dim ÖrnekDosya, YeniDosya, Firma As Variant
Dim kitap As Workbook
Dim syfYeni As Worksheet
Dim syfFirmalar As Worksheet
Const syfÖzet As String = "Özet"
Set syfYeni = ThisWorkbook.Sheets("YeniKayýt")
Set syfFirmalar = ThisWorkbook.Sheets("Firmalar")
With syfFirmalar
.Unprotect
.Cells.Locked = True
End With
Application.ScreenUpdating = False
' Tanymlamalar
With syfYeni.Range("D3")
If .Value = "" Then
syfYeni.Select
.Select
MsgBox "Müsteri Adi kismi bos olamaz..", vbCritical, "Hata"
GoTo son
End If
Firma = .Value
End With
ÖrnekDosya = ActiveWorkbook.Path & "\Örnek.xlsx"
YeniDosya = ActiveWorkbook.Path & "\" & Firma & ".xlsx"
' Dosya Kopyala
FileCopy ÖrnekDosya, YeniDosya
' Listedeki Bilgileri Kopyala
syfYeni.Range("D315").Copy
' Yeni Dosyayy Aç
Set kitap = Workbooks.Open(YeniDosya)
With kitap
.Worksheets(syfÖzet).Select
.Worksheets(syfÖzet).Range("D3").PasteSpecial xlPasteValues
.Worksheets(syfÖzet).Range("D3").Select
End With
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close
With syfFirmalar
.Select
If WorksheetFunction.CountA(.Range("A4:A" & Rows.Count)) = 0 Then
.Rows("1:1").Copy .Range("A4")
.Rows(4).Replace What:="Örnek", Replacement:=Firma, LookAt:=xlPart
Else
.Rows("1:1").Copy .Range("A" & Rows.Count).End(3)(2, 1)
satir = .Range("A" & Rows.Count).End(3).Row
.Rows(satir).Replace What:="Örnek", Replacement:=Firma, LookAt:=xlPart
End If
.Range("A" & Rows.Count).End(3)(2, 1).Select
End With
With syfYeni
.Select
.Range("D315").ClearContents
.Range("D3").Select
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Ýþlem Tamamlandý.Kayýt Baþarýyla Gerçekleþtirildi"
son:
Set kitap = Nothing
Set syfYeni = Nothing
Set syfFirmalar = Nothing
With syfFirmalar
.Protect
End With
End Sub
Sn@feraz kodu uyguladim ama bir sey degismedi.
Access Çekirgesi