Excelde 2 Satır Arasına Vba İle Yeni Kayıt Ekleme.

sayın site üyeleri ve ustalar.

excel de bir çalışma sayfasında (Sayfa1 diyelim) veri giriliyor. Sayfa1 çalışma sayfasında 1 sütunda (B sütunu) sabit bilgi olan iki satır olduğunu varsayalım.

Sayfa1 veri girilen hücreler E3,F3,G3,H3,I3.
Sayfa1 de B sütunundaki sabit satırlar B7 ve B8.

E3 hücresine bir bilgi yazıldığında bu bilgi B sütunundaki B7 ve B8 satırlarının arasına eklensin. (Burada artık 3 kayıt oldu. B7'de sabit kayıt, B8'de E3'de eklenen yeni kayıt ve B9'da diğer sabit kayıt)
F3 hücresine bir bilgi yazıldığında bu bilgi B sütunundaki B8 ve B9 satırlarının arasına eklensin. (Burada artık 4 kayıt oldu. B7'de sabit kayıt, B8'de E3'e eklenen kayıt, B9'da F3'de eklenen yeni kayıt ve B10'da diğer sabit kayıt)

G3 hücresine bir bilgi yazıldığında bu bilgi B sütunundaki B9 ve B10 satırlarının arasına eklensin. (Burada artık 5 kayıt oldu. B7'de sabit kayıt, B8'de E3'e eklenen kayıt, B9'da F3'de eklenen kayıt, B10'da G3'de eklenen yeni kayıt ve B11'da diğer sabit kayıt)

bu tekrar I3 hücresine kadar devam ederek gidecek.

bu ekleme olayı.

silme olayında da silme işlemi I3 hücresinden başlayarak E3 hücresine doğru ilerleyecek ve her
silme işleminden sonra B11 deki sabit kayıt eski sırasına doğru geri dönmüş olacak.

bunu bu şekilde neden yapmak istediğimi sorarsanız çalışılan sayfada sabit hücreler arasına eklene bilgileri başka sayfada gösteren kod dizini var.

bu şekilde çok çalışma sayfası var ve tüm çalışma sayfalarının listelendiği ve listedeki çalışma sayfalarında her hangi seçildiğinde o sayfaya ait bu kayıtlar görünecek. Üstte ve altta sabit bilgi arada eklenmiş olan kaç adet bilgi varsa onlar.

bir dosya eklemiyorum çünkü ihtiyacım alan sadece kod.

saygılar iyi çalışmalar

kodunu deneyin. Bu kod E3:I3 aralığında hücrelere sırası ile değer girdiğinizde B7:B8 arasına satır ekleyerek eklenen satırın B sütununa değeri yazar. E3:I3 aralığında tersten başlayarak (I3den E3e doğru) hücre verisini delete ile sildiğinizde eklenen satırı eski sıralama dönecek şekilde siler.

elinize sağlık sayın Atoykan istediğim şekilde olmuş. bir sorum daha olacak siz ve site sakinlerine.

Sayın Atoykanın verdiği kodda düzenleme yaptım. ama bu kodu başka bir kodla birleştirmem gerekiyor ama yapamadım.

bu kodu:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cellsarr As Variant, i As Integer


cellsarr = Array("F3", "G3", "H3", "I3", "J3", "K3", "L3", "M3", "N3", "O3", "P3", "Q3", "R3", "S3", "T3", "U3", "V3", "W3", "X3", "Y3")

' İzlenen hücreleri belirle


For i = LBound(cellsarr) To UBound(cellsarr)
Dim CurrentCell As Range
Set CurrentCell = Me.Range(cellsarr(i))

' Hücreye değer girildiyse ve değeri boş değilse satır ekle ve değeri yaz, değer silindi ise satırı sil
If Not Intersect(Target, CurrentCell) Is Nothing Then
Application.EnableEvents = False

'Buradaki sayı verinin ekleneceği satır başlangıcı
If CurrentCell.Value <> "" Then
Me.Rows(i + 24 & ":" & i + 24).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Me.Cells(i + 8, 2).Value = CurrentCell.Value
Else
Me.Rows(i + 24).Delete Shift:=xlUp
End If

Application.EnableEvents = True
End If
Next i
End Sub

bu koda birleştirmek gerekiyor. üstteki kodun
cellsarr = Array("F3", "G3", "H3", "I3", "J3", "K3", "L3", "M3", "N3", "O3", "P3", "Q3", "R3", "S3", "T3", "U3", "V3", "W3", "X3", "Y3") satırındaki veriler ana sayfada hesaplama ile geliyor. o yüzden iki kodu entegre etmek gerekiyor.

Ana kod:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Set ws = ActiveSheet

' Eğer B4:B18 arasında bir değişiklik yapıldıysa
If Not Intersect(Target, ws.Range("B4:B18")) Is Nothing Then
Dim i As Long
For i = 5 To 18
' Eğer bir üst satırda veri varsa ve alt satır gizli ise aç
If ws.Cells(i - 1, 2).Value <> "" And ws.Rows(i).Hidden Then
ws.Rows(i).Hidden = False
ws.Cells(i, 2).Select ' Açılan satıra odaklan

Exit For
End If
Next i

' Eğer bir üst satırda veri yoksa ve alt satırda veri yoksa, satırı gizle
For j = 18 To 5 Step -1
If ws.Cells(j, 2).Value = "" And ws.Cells(j - 1, 2).Value = "" Then
ws.Rows(j).Hidden = True

End If
Next j
End If
' I3:Y3 satırlarını kontrol et
For Each col In ws.Range("I3:Y3").Columns
If Application.WorksheetFunction.CountA(col) = 0 Then
col.EntireColumn.Hidden = True
Else
col.EntireColumn.Hidden = False
col.EntireColumn.ColumnWidth = 6 ' Sütun genişliği 6 cm olarak ayarlanıyor

End If
Next col

' Diğer koşullar buraya eklenebilir
If Not Intersect(Target, ws.Range("G22")) Is Nothing Then
ws.Name = ws.Range("G22").Value
End If
If Not Intersect(Target, ws.Range("B4:B18")) Is Nothing Then
ws.Range("G3:Y3").Value = ""
Aktar
End If
End Sub

saygılar iyi çalışmalar.

1. Her konuda tek bir soru sorun. Adet haline getirdiniz her sorunuz cevaplandığında altına yeni bir soru ekliyorsunuz.
   
2. Örneğiniz nerede? Basit veya teknik bilgi sorularına örnek yoksa cevap vermeye çalışıyoruz onun dışında sizler için örnek hazırlayacak zamanımız yok.
   

Yoğunluktan evime gidemiyorum 5 dk molada bakayım yardımcı olalım diyorum da biraz da sizler kurallara riayet edip bizlere yardımcı olsanız. Yeni konu açın, örneğinizi ekleyin ne yapmak istediğinizi, nasıl işleyeceğini nerede takıldığınızı anlaşılır bir şekilde kısa, öz anlatın yardımcı olmaya çalışalım.

(24/11/2023, 20:08)atoykan yazdı:

1. Her konuda tek bir soru sorun. Adet haline getirdiniz her sorunuz cevaplandığında altına yeni bir soru ekliyorsunuz.
   
2. Örneğiniz nerede? Basit veya teknik bilgi sorularına örnek yoksa cevap vermeye çalışıyoruz onun dışında sizler için örnek hazırlayacak zamanımız yok.
   

Yoğunluktan evime gidemiyorum 5 dk molada bakayım yardımcı olalım diyorum da biraz da sizler kurallara riayet edip bizlere yardımcı olsanız. Yeni konu açın, örneğinizi ekleyin ne yapmak istediğinizi, nasıl işleyeceğini nerede takıldığınızı anlaşılır bir şekilde kısa, öz anlatın yardımcı olmaya çalışalım.

çok özür diliyorum. sizde haklısınız. yeni konu açıp mutlaka basit bir örnek ekleyeceğim. bundan sonra kurallara daha dikkat edeceğim.

saygılar.