satır ve sütunların eklenmesi

[qazedctgb]

merhabalar sabah benzer bir soru sormuştum ama bu sefer iş biraz karıştı.
yardımcı olursanız sevinirim.

1. olarak A sayfasında sutun 1 de ilgili satırına değer girince otomatik artan sıra no yapmak istiyorum.
2. olarak ise A sayfasındaki verileri veri girildiğinde veya değiştirildiğinde eşzamanlı olarak B sayfasında farklı sutunlara gondermek ve işlem yaptırmak istiyorum.

veri sayısı çok oldugu için makro yazmak gerekiyor.

tşklr

örnek ektedir.

 

[Mahir64]

Merhaba
Sıra numarası için,
A6 yazarak aşağı çekin

=EĞER(B6="";"";A5+1)

Eş zamanlıdan kastınız nedir? Veriler kalıcı olarakmı aktarılacak nasıl olacak?

 

[qazedctgb]

5000 adet satır yaklaşık 50 sutun olunca hiç veri girmeden bu şekilde dosya boyutu cok oluyor o yuzden kodla yapmak istiyorum. ilginize tşklr

eş zamanlı derken dosyayı kaydedip tekrar açtıgımda değilde verileri girerken veya değiştirirken anında ilgili hücrelere değerlerin aktarılması

otomatik artırma dışında şöyle bir denemem oldu ama başarısız

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set s1 = Sheets("A")
Set s2 = Sheets("B")

s1.Select
For i = 5 To s1.Range("A5000").End(5).Row
For j = 5 To s2.Range("A5000").End(6).Row

If IsNumeric(s1.Cells(i, 1).Value) Then


s2.Cells(j, 6).Value = s1.Cells(i, 3).Value + s1.Cells(i, 4).Value

s2.Select
sonsat = s2.Range("A5000").End(6).Row + 1

s2.Cells(j, 1).Value = s1.Cells(i, 1).Value
s2.Cells(j, 2).Value = s1.Cells(i, 2).Value
s2.Cells(j, 3).Value = s1.Cells(i, 4).Value
s2.Cells(j, 4).Value = s1.Cells(i, 3).Value


s1.Cells(i, 5).Value = s2.Cells(j, 6).Value
End If




Next

s1.Select
Application.ScreenUpdating = True
End Sub

 

[AS3434]

Sayın qazedctgb

Aşağıdaki kodları dener misiniz?


.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [d5:d5000]) Is Nothing Then Exit Sub
   Set sh1 = Sheets("A")
   Set sh2 = Sheets("B")
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    For sat = 5 To [b5000].End(3).Row
    If Cells(sat, 4) <> "" Then
      Cells(sat, 1) = Cells(sat - 1, 1) + 1
      Cells(sat, 5) = Cells(sat, 3) + Cells(sat, 4)
      sh2.Cells(sat, 1) = sh1.Cells(sat, 1)
      sh2.Cells(sat, 2) = sh1.Cells(sat, 2)
      sh2.Cells(sat, 5) = sh1.Cells(sat, 3)
      sh2.Cells(sat, 4) = sh1.Cells(sat, 4)
      sh2.Cells(sat, 6) = sh1.Cells(sat, 5)
    End If
    Next
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

İşlem sırasınızı bilmediğim için mavi renkli hücreleri baz aldım...



.

 

[qazedctgb]

elinize sağlık çok güzel olmuş yalnız değer girilmiş bir satırda değişiklik yaptığım zaman onu görmüyor. onun nedeni de zannederim makroda 4 sutunu baz almamızdan kaynaklanıyor. onun dışında mükemmel tşklr.

 

[AS3434]

Sayın qazedctgb

Makro sadece D sütununa (Mavi) değer girince çalışır.

Mantık olarak önce tarih (B sütunu) yazılır sonra 1.değer (C Sütunu) ve en son 2. değer (D sütunu) yazılır diye düşündüm. Yani son değeri yazınca makro çalışıyor.
Bu 3 sütunuda baz alırsak her veri girişinde makro çalışacak ve işlem yapma süreniz uzayacak.
Sonuç olarak, B ve C sütunlarındaki verileri değiştirseniz bile D sütunudaki hücrelerden birinde, değiştirmeseniz bile mutlaka veriyi yenilemeniz gerekecek...


.

 

[qazedctgb]

dediğiniz mantıkla yaptım oldu. çok tşklr.

son bir şey kaldı sizin verdiğiniz kod altyapısı ile sadece iki sutundaki satır değerlerini değilde örneğin
(1. ile 10 cu sutunları arasındaki satırların toplamları) + (20 ile 30 sutunlarınnın arasındaki satırların toplamları)

almak için nasıl bir kod kullanılır.

aslında aralıkları tek tek girip +++++ şeklinde yapıyorum ama 20 ye yakın sutun oldugu için hata yapma olasılığını azaltmak istiyorum

su ana kadar ki yardımlarınız bile benim için haddinden fazla yeterli oldu. en içten tşklrimi iletirim.

 

[AS3434]

Sayın qazedctgb

Şöyle deneyebilirsiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [d5:d5000]) Is Nothing Then Exit Sub
   Set sh1 = Sheets("A")
   Set sh2 = Sheets("B")
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    For sat = 5 To [b5000].End(3).Row
    If Cells(sat, 4) <> "" Then
      Cells(sat, 1) = Cells(sat - 1, 1) + 1
      Cells(sat, 5) = Cells(sat, 3) + Cells(sat, 4)
      sh2.Cells(sat, 1) = sh1.Cells(sat, 1)
      sh2.Cells(sat, 2) = sh1.Cells(sat, 2)
      sh2.Cells(sat, 5) = sh1.Cells(sat, 3)
      sh2.Cells(sat, 4) = sh1.Cells(sat, 4)
      sh2.Cells(sat, 6) = sh1.Cells(sat, 5)
 
    [COLOR=red]  top1 =[/COLOR][COLOR=#ff0000] WorksheetFunction.Sum(Range(Cells(sat, 1), Cells(sat, 10))) [/COLOR]
[COLOR=#ff0000]     top2 = WorksheetFunction.Sum(Range(Cells(sat, 20), Cells(sat,30))) [/COLOR]
      [COLOR=red]sh1.Cells(sat, 31) =top1 + top2[/COLOR] 
    End If
    Next
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

.

 

[qazedctgb]

evet tam da istediğim gibi oldu. öncelikle ilginize sonra da çözüm için çok teşekkur ederim.