kodlarda değişiklik

[acebeci]

Sub Kopyala()
Dim i As Integer
Dim kopya
For i = 1 To Worksheets.Count
sayfa = Sheets(i).Name & vbNewLine & sayfa
Next i
kopya = InputBox("Kopyalamak İstediğiniz Sayfanın adını giriniz" _
& vbCrLf _
& sayfa, "Kopya", "Şablon")
If kopya = Empty Then Exit Sub
For i = 1 To Worksheets.Count
If kopya = Sheets(i).Name Then: MsgBox "Bu isimde bir müşteri zaten kayıtlı", vbCritical, "UYARI": Exit Sub
Next i
Sheets("Şablon").Copy after:=Sheets(Worksheets.Count)
On Error GoTo hata
ActiveSheet.Name = kopya
Range("A1").Value = kopya
sonsatir = Sheets("LİSTE").Cells(65536, 1).End(xlUp).Row
With Sheets("LİSTE")
.Cells(sonsatir + 1, 1) = kopya
.Cells(sonsatir + 1, 2).Formula = "='" & .Cells(sonsatir + 1, 1) & "'!F2"
.Cells(sonsatir + 1, 3).Formula = "='" & .Cells(sonsatir + 1, 1) & "'!H2"
.Cells(sonsatir + 1, 4).Formula = "='" & .Cells(sonsatir + 1, 1) & "'!K2"
.Cells(sonsatir + 1, 5).Formula = "='" & .Cells(sonsatir + 1, 1) & "'!P2"
.Cells(sonsatir + 1, 6).Formula = "='" & .Cells(sonsatir + 1, 1) & "'!D2"
.Range("A1:F" & sonsatir + 1).Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlGuess
End With
hata:
End Sub

Çok değerli arkadaşlar yukarda gönderdiğim kodlarda şöyle bir değişiklik yapmak istiyorum:
1-Daha önce liste sayfasına veri otamatik eklenirken 1 ci sütündan verileri kaydetmeye başlıyordu ben 1.sutüna sıra no diye yeni bir sütün ekledim.dolayısı ile verileri kaydetmeye B3 ile G3 arasına yapmak istiyorumYani A3 hücresine sıranoyu 1 ile başlatıp her yeni eklenen veride 2-3-4.... gibi otamatik sırano vermesini istiyorum bu konuda yardımcı olabilirseniz çok memnun olurum.şimdiden teşekkürler

 

[Orion1]

Kodlardaki ilgili bölümü aşağıdaki kodlarla değiştiriniz.

With Sheets("LİSTE")
.Cells(sonsatir + 1, 1) = sonsatir
.Cells(sonsatir + 1, 2) = kopya
.Cells(sonsatir + 1, 3).Formula = "='" & .Cells(sonsatir + 1, 1) & "'!F2"
.Cells(sonsatir + 1, 4).Formula = "='" & .Cells(sonsatir + 1, 1) & "'!H2"
.Cells(sonsatir + 1, 5).Formula = "='" & .Cells(sonsatir + 1, 1) & "'!K2"
.Cells(sonsatir + 1, 6).Formula = "='" & .Cells(sonsatir + 1, 1) & "'!P2"
.Cells(sonsatir + 1, 7).Formula = "='" & .Cells(sonsatir + 1, 1) & "'!D2"
.Range("A1:G" & sonsatir + 1).Sort Key1:=.Range("B2"), Order1:=xlAscending, Header:=xlGuess
End With

 

[acebeci]

Sayın Evren ilginizden dolayı çok teşekkür ederim bu çalışmalarımda sizin emeğiniz gerçekten tartışılmaz.
Sayın Evren gönder miş olduğunuz kodu aynısı ile uyguladığımda güncelenecek veriler diye bir pencere açılıyor
With Sheets("LİSTE")
.Cells(sonsatir + 1, 1) = sonsatir
.Cells(sonsatir + 1, 2) = kopya
.Cells(sonsatir + 1, 3).Formula = "='" & .Cells(sonsatir + 1, 1) & "'!F2"
.Cells(sonsatir + 1, 4).Formula = "='" & .Cells(sonsatir + 1, 1) & "'!H2"
.Cells(sonsatir + 1, 5).Formula = "='" & .Cells(sonsatir + 1, 1) & "'!K2"
.Cells(sonsatir + 1, 6).Formula = "='" & .Cells(sonsatir + 1, 1) & "'!P2"
.Cells(sonsatir + 1, 7).Formula = "='" & .Cells(sonsatir + 1, 1) & "'!D2"
.Range("A1:G" & sonsatir + 1).Sort Key1:=.Range("B2"), Order1:=xlAscending, Header:=xlGuess
End With
kodu aşağıdaki gibi değistirince hata vermiyor gibi daha sonra bir problem çıkarır mı acama
With Sheets("LİSTE")
.Cells(sonsatir + 1, 1) = sonsatir
.Cells(sonsatir + 1, 2) = kopya
.Cells(sonsatir + 1, 3).Formula = "='" & .Cells(sonsatir + 1, 2) & "'!F2"
.Cells(sonsatir + 1, 4).Formula = "='" & .Cells(sonsatir + 1, 2) & "'!H2"
.Cells(sonsatir + 1, 5).Formula = "='" & .Cells(sonsatir + 1, 2) & "'!K2"
.Cells(sonsatir + 1, 6).Formula = "='" & .Cells(sonsatir + 1, 2) & "'!P2"
.Cells(sonsatir + 1, 7).Formula = "='" & .Cells(sonsatir + 1, 2) & "'!D2"
.Range("A1:G" & sonsatir + 1).Sort Key1:=.Range("B2"), Order1:=xlAscending, Header:=xlGuess
End With

 

[Orion1]

Evet benim formüller gözümden kaçmış.Onları düzeltmemişim.
Sizn yaptığınz şekilde olacak ama kodu çalıştırdıktan sonra bir kere formül oluşan hücreleri kontrol etmenizde fayda var.
İyi çalışmalar.

 

[acebeci]

Tamam galiba hiç problem yok gibi çok teşekkür ederim emeğinize sağlık

 

[Orion1]

Tamam galiba hiç problem yok gibi çok teşekkür ederim emeğinize sağlık

Rica ederim.
İyi çalışmalar.