Biçimi ile ve Son dolu satırı alt satıra kopyala ve yapıştır.

[kkkazan]

Sayın ilgili,

Dosyamda aşağıdaki kodları kullanarak bir Userform oluşturdum. Sayfa 1 de butonla açılan userform daki satırlara yazdıklarım Sayfa 1 de Son boş satıra gidip belirtmiş olduğum aralıklara yapışıyor (Bir yeni müşteri açma formu bilgileri ile ) . Bu durumda sorun yaşamıyorum fakat devamı olarak araya eklemek istediğim şey Yine Sayfa 1 de ''J:AA '' arasında formüller kullandığım satırı yeni oluşan müşterinin satırına aynı şekilde kopyalasın ki işlem devam edebilsin. ve tabii son satırın biçiminide aynı şekilde kopyalması gerekiyor.

Userform ( Müşteri bilgisi ekleme )

Private Sub CommandButton1_Click()
Range("A2").Select
Do While Not IsEmpty(Activecell)
Activecell.Offset(1, 0).Select
Loop
If IsNumeric(Activecell.Offset(-1, 0).Value) = True Then
Activecell.Value = Activecell.Offset(-1, 0).Value
End If
Activecell.Offset.Value = TextBox1.Text
Activecell.Offset(0, 1).Value = TextBox2.Text
Activecell.Offset(0, 4).Value = TextBox3.Text
Activecell.Offset(0, 6).Value = TextBox4.Text
MsgBox ("Kayıt Tamamlandı")
TextBox1.Text = ""
TextBox2.Text = ""
TextBox3.Text = ""
TextBox4.Text = ""
End Sub

 

[kkkazan]

bu konuda yardımcı olabilecek birisi varmı??? )

 

[kkkazan]

Sayın Korhan bey, yada destek ekibi,

Userform içinde bu işlem kafa karıştırdı benim açımdan yukarıda belirtilen kopyalama işlemini userformu çağıran kod kısmın da yapabilirmiyiz?

beklentim açık aslında Userform ile oluşturulan müşteri listesi A,B,C,D de işlem yapıyor J:AA arasında ise formüller var fakat yeni girilen satırda (en son satır) üsteki formüller gelmiyor onlarında gelmesi için bir kod rica ediyorum.

Sub Button29_Click()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

UserForm1.Show

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

 

[Korhan Ayhan]

Deneyiniz.

Private Sub CommandButton1_Click()
    Range("A2").Select
    Do While Not IsEmpty(ActiveCell)
    ActiveCell.Offset(1, 0).Select
    Loop
    If IsNumeric(ActiveCell.Offset(-1, 0).Value) = True Then
    ActiveCell.Value = ActiveCell.Offset(-1, 0).Value
    End If
    ActiveCell.Offset.Value = TextBox1.Text
    ActiveCell.Offset(0, 1).Value = TextBox2.Text
    ActiveCell.Offset(0, 4).Value = TextBox3.Text
    ActiveCell.Offset(0, 6).Value = TextBox4.Text
    Range("J" & ActiveCell.Row - 1 & ":AA" & ActiveCell.Row - 1).Copy Range("J" & ActiveCell.Row)
    MsgBox ("Kayıt Tamamlandı")
    TextBox1.Text = ""
    TextBox2.Text = ""
    TextBox3.Text = ""
    TextBox4.Text = ""
End Sub

 

[kkkazan]

Korhan bey çok güzel olmuş elinize sağlık ama userform üzerinde A sutununa atatığım değer(firma adı) için bir üstündeki satırın da biçim boyasının gelmesi gerekiyor çünkü orda kural oluşturmuştum. bu konuda bir çözümünüz varsa harika olur.

 

[kkkazan]

korhan Bey aşağıdaki kodu ekledim oldu tekrar teşekkürler şimdilik hoşçakalın ama burda kalın )

Range("A" & ActiveCell.Row - 1).Copy

Range("A" & ActiveCell.Row).PasteSpecial Paste:=xlPasteFormats

 

[kkkazan]

Korhan Bey başka bir sorun oldu J:AA arasında gizlenmiş sutunlar vardı (M den R dahil ) ve (V den Z dahil ) bunlarda kopyalama yapmıyor , eğer açıksa yapıyor kapalıysa yapmıyor

 

[kkkazan]

Yani bir sutun dahi gizlenmiş olsa formülasyonu bozuluyor .
Denemek için (M den R dahil ) bu sutunları kapadım (V den Z dahil ) bu sutunları açtım , sadece kapalı olanlarımı etkiliyor diye ama diğerleride bozuluyor.

 

[Korhan Ayhan]

Merhaba,

Sütunun kapalı olması kopyalanmasına engel olmaması gerekir. Sizin dosyanızda başka bir durum olabilir.

Dosyanızı paylaşırsanız (paylaşım sitelerine yükleyip link verebilirsiniz) inceleme fırsatımız olabilir.

 

[kkkazan]

Korhan Bey Hallettim sanırım vermiş olduğunuz örnekten yola çıkarak tek tek her satıra ayrı ayrı yaptım arada formül olmayan hücreleri eledim. şu an çalışıyor. Tekrar teşekkürler ))


Private Sub CommandButton1_Click()
Range("A2").Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
If IsNumeric(ActiveCell.Offset(-1, 0).Value) = True Then
ActiveCell.Value = ActiveCell.Offset(-1, 0).Value
End If
ActiveCell.Offset.Value = TextBox1.Text
ActiveCell.Offset(0, 1).Value = TextBox2.Text
ActiveCell.Offset(0, 4).Value = TextBox3.Text
ActiveCell.Offset(0, 6).Value = TextBox4.Text
Range("J" & ActiveCell.Row - 1).Copy Range("J" & ActiveCell.Row)
Range("K" & ActiveCell.Row - 1).Copy Range("K" & ActiveCell.Row)
Range("L" & ActiveCell.Row - 1).Copy Range("L" & ActiveCell.Row)
Range("M" & ActiveCell.Row - 1).Copy Range("M" & ActiveCell.Row)
Range("O" & ActiveCell.Row - 1).Copy Range("O" & ActiveCell.Row)
Range("Q" & ActiveCell.Row - 1).Copy Range("Q" & ActiveCell.Row)
Range("S" & ActiveCell.Row - 1).Copy Range("S" & ActiveCell.Row)
Range("T" & ActiveCell.Row - 1).Copy Range("T" & ActiveCell.Row)
Range("U" & ActiveCell.Row - 1).Copy Range("U" & ActiveCell.Row)
Range("V" & ActiveCell.Row - 1).Copy Range("V" & ActiveCell.Row)
Range("W" & ActiveCell.Row - 1).Copy Range("W" & ActiveCell.Row)
Range("X" & ActiveCell.Row - 1).Copy Range("X" & ActiveCell.Row)
Range("Y" & ActiveCell.Row - 1).Copy Range("Y" & ActiveCell.Row)
Range("Z" & ActiveCell.Row - 1).Copy Range("Z" & ActiveCell.Row)
Range("AA" & ActiveCell.Row - 1).Copy Range("AA" & ActiveCell.Row)

Range("A" & ActiveCell.Row - 1).Copy
Range("A" & ActiveCell.Row).PasteSpecial Paste:=xlPasteFormats
TextBox1.Text = ""
TextBox2.Text = ""
TextBox3.Text = ""
TextBox4.Text = ""
MsgBox ("Kayıt Tamamlandı")

End Sub