- Dosya \ Seçenekler
- Güven Merkezi \ Güven Merkezi Ayarları
- Gizlilik Seçenekleri \ Kaydederken dosya özelliklerinden kişisel bilgileri kaldır seçeneğini iptal ediniz.
Kod:
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")
Application.ScreenUpdating = False
' Tanýmlamalar
With syfYeni.Range("D3")
If .Value = "" Then
.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("D3:D15").Copy
' Yeni Dosyayý Aç
Set kitap = Workbooks.Open(YeniDosya)
With kitap
.Worksheets(syfÖzet).Select
.Worksheets(syfÖzet).Range("D3").PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close
With syfFirmalar
.Select
.Rows("1:1").Copy .Range("A" & Rows.Count).End(3)(2, 1)
.Range("B" & Rows.Count).End(3).Value = Firma
.Range("A" & Rows.Count).End(3)(2, 1).Select
End With
With syfYeni
.Select
.Range("D3").Select
.Range("D3:D15").ClearContents
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Bitti"
son:
Set kitap = Nothing
Set syfYeni = Nothing
Set syfFirmalar = Nothing
End Sub