yeni sayfa ekleyip klasöre gönderme veri girip alma

[aydın3838]

selamlar

örnek dosyada açıklamalı anlatımı var
sorum şu
tek kitapta şablon sayfayı kopyalayıp sayfa ismini kişiye atıyorum
ve form larla veri girişi ve çıkışı yapabiliyorum
fakat 50 ve 60 sayfadan sonra excelde ağırlaşmalar başlıyor
bende yeni bir klasöre kayıt yapmak istedim bir kaç örneklede denedim ama başarılı olamadım ve tekrardan hocalarıma döndüm
yardımlarınızı bekliyorum

teşekkürler

 

[aydın3838]

yardım edecek yokmu arkadaşlar

 

[aydın3838]

bu kodla sayfa 1e isim kaydı yapıyorum

Private Sub CommandButton1_Click()
'KAYDET BUTONU

Application.ScreenUpdating = False
If Sayfa1.Range("A2").Value = "" Then
Sayfa1.Range("A2").Value = 1
Sayfa1.Range("B2" & s).Value = TextBox2.Text
Sayfa1.Range("C2" & s).Value = TextBox3.Text
Sayfa1.Range("D2" & s).Value = TextBox4.Text
Sayfa1.Range("E2" & s).Value = TextBox5.Text
Sayfa1.Range("F2" & s).Value = TextBox6.Text
Sayfa1.Range("G2" & s).Value = TextBox7.Text
Sayfa1.Range("H2" & s).Value = TextBox8.Text
Sayfa1.Range("I2" & s).Value = TextBox9.Text
Sayfa1.Range("J2" & s).Value = TextBox10.Text
Sayfa1.Range("K2" & s).Value = TextBox11.Text
Sayfa1.Range("L2" & s).Value = TextBox12.Text
If Sayfa1.Range("A2").Value <> "" Then
s = WorksheetFunction.CountA(Sayfa1.Range("A:A"))
ListBox1.RowSource = "sayfa1!a2:b" & s
ListBox1.ColumnCount = 2
ListBox1.ColumnWidths = 25
ComboBox1.RowSource = "sayfa1!B2:b" & s
End If
'aynı veri varmı bak
For bak = 1 To [b6536].End(xlUp).Row
If Range("a" & bak) Like TextBox2 Then
MsgBox "Bu isimde bir kaydınız mevcut.", vbInformation
Exit Sub
End If
Next

TextBox1.Text = TextBox1 + 1
TextBox2.Text = ""
TextBox3.Text = ""
TextBox4.Text = ""
TextBox5.Text = ""
TextBox6.Text = ""
TextBox7.Text = ""
TextBox8.Text = ""
TextBox9.Text = ""
TextBox10.Text = ""
TextBox11.Text = ""
TextBox12.Text = ""
TextBox2.SetFocus
Else
s = WorksheetFunction.CountA(Sayfa1.Range("A:A")) + 1
Sayfa1.Range("A" & s).Value = Sayfa1.Range("A" & s - 1).Value + 1
Sayfa1.Range("B" & s).Value = TextBox2.Text
Sayfa1.Range("C" & s).Value = TextBox3.Text
Sayfa1.Range("D" & s).Value = TextBox4.Text
Sayfa1.Range("E" & s).Value = TextBox5.Text
Sayfa1.Range("F" & s).Value = TextBox6.Text
Sayfa1.Range("G" & s).Value = TextBox7.Text
Sayfa1.Range("H" & s).Value = TextBox8.Text
Sayfa1.Range("I" & s).Value = TextBox9.Text
Sayfa1.Range("J" & s).Value = TextBox10.Text
Sayfa1.Range("k" & s).Value = TextBox11.Text
Sayfa1.Range("L" & s).Value = TextBox12.Text
ListBox1.RowSource = "sayfa1!a2:b" & s
ListBox1.ColumnCount = 2
ListBox1.ColumnWidths = 25
ComboBox1.RowSource = "sayfa1!B2:b" & s

TextBox1.Text = TextBox1 + 1
TextBox2.Text = ""
TextBox3.Text = ""
TextBox4.Text = ""
TextBox5.Text = ""
TextBox6.Text = ""
TextBox7.Text = ""
TextBox8.Text = ""
TextBox9.Text = ""
TextBox10.Text = ""
TextBox11.Text = ""
TextBox12.Text = ""
TextBox2.SetFocus
End If
Application.ScreenUpdating = True
On Error Resume Next

'ilerleme çubuğunu çalıştır
ProgressBar1.Visible = True
For i = 1 To 10000
ProgressBar1 = i / 10000 * 260
Next
'ilerleme çubuğunu gizle
ProgressBar1.Visible = False
Unload UserForm1
Sheets("ANA").Select
UserForm5.Show
End Sub

bu kodla ise sayfa1e yaptığım yukarıdaki kodla yanı

yeni bir sayfa açıp sayfa 1 a2 deki sıralı numarayı sayfa ismi olarak atıyorum

benim düşüncem ise örnekteki müşteri kartları dosyasına göndermesi ve işlemleri oradan yapması

Private Sub CommandButton1_Click()
'Kaydet Butonu
On Error Resume Next
Dim sayf As Worksheet
syf = UCase(Replace(Replace(TextBox1.Value, "ı", "I"), "i", "İ"))
If syf = "" Then Exit Sub
For Each sayf In Worksheets
If syf = UCase(Replace(Replace(sayf.Name, "ı", "I"), "i", "İ")) Then
MsgBox syf & " Bu Kodda Bir Müşteri Kartınız var kayıt yapılmadı..!!", vbCritical, "DİKKAT"
Exit Sub
End If
Next

sıra = ActiveWorkbook.Sheets.Count
Sheets("MÜŞTERİ KARTI").Select
Sheets("MÜŞTERİ KARTI").Copy After:=Sheets(sıra)
'Sheets("MÜŞTERİ KARTI").Copy Before:=Sheets(1)
Sheets("MÜŞTERİ KARTI (2)").Select
Sheets("MÜŞTERİ KARTI (2)").Name = syf
On Error Resume Next
'ilerleme çubuğunu çalıştır
ProgressBar1.Visible = True
For i = 1 To 10000
ProgressBar1 = i / 10000 * 260
Next
'ilerleme çubuğunu gizle
ProgressBar1.Visible = False
MsgBox syf & " Kod Numaralı Müşteri Kartı Açıldı..!!", vbOKOnly + vbInformation, "SAYFA"

Worksheets(syf).Cells(3, 2).Value = TextBox1.Value 'KOD
Worksheets(syf).Cells(4, 2).Value = TextBox2.Value 'TARİH
Worksheets(syf).Cells(5, 2).Value = TextBox3.Value 'MÜŞTERİ İSMİ
Worksheets(syf).Cells(6, 2).Value = TextBox4.Value 'ADRES
Worksheets(syf).Cells(8, 2).Value = TextBox5.Value 'NAKİT SATIŞ
Worksheets(syf).Cells(9, 2).Value = TextBox6.Value 'TAKSİTLİ SATIŞ
Worksheets(syf).Cells(10, 2).Value = TextBox7.Value 'PEŞİNAT
Worksheets(syf).Cells(11, 2).Value = TextBox8.Value 'TAKSİT TARİHİ
Worksheets(syf).Cells(12, 2).Value = TextBox9.Value 'TAKSİT SAYISI
Worksheets(syf).Cells(13, 2).Value = TextBox10.Value 'NOTLAR
TextBox1.Text = WorksheetFunction.CountA(Worksheets("Sayfa1").Range("A2:A65000")) + 0
ComboBox1.Clear
For i = 1 To ActiveWorkbook.Sheets.Count
ComboBox1.AddItem Sheets(i).Name
Next
Unload UserForm3
Sheets("ANA").Select
UserForm1.Show
End Sub