sütun kontrolü ve otomatik satır ekleme

[mkagan16]

Arkadaşlar merhaba.Çok acil yardımınıza ihtiyacım var.
Yaklaşık 43000 satırdan 6 sütundan oluşan bir excel dosyam var.1 sütundaki sayılar yukarıdan aşağıya doğru 0 dan 23 e kadar gidiyor ardından tekrar 0 oluyor.Yani döngü toplam 24 terimden oluşuyor.Ama bazı yerlerde 1,2 veya 3 adet terim atlanmış.Örneğin: 3,4,8,9,10.....
Benim istediğim şey,bunları tespit edip araya eksik terim kadar satır eklemek ve diğer 4 sütundan sadece 3 tanesine yeni eklenen satıra,bir üstteki değeri yazdırmak ve 1 sütunu boş bırakmak.
Bunu nasıl çözebilirim yardımlarınızı bekliyorum.Şimdiden çok teşekkürler.

 

[Ömer BARAN]

Merhaba, foruma hoşgeldiniz.

Sorunuzu örnek belgeyle destekleyiniz.
Örnek belge özellikleri ve örnek belge yükleme yöntemine ilişkin açıklama, cevabımın alt kısmındaki İMZA bölümünde var.
.

 

[mkagan16]

Merhaba, foruma hoşgeldiniz.

Sorunuzu örnek belgeyle destekleyiniz.
Örnek belge özellikleri ve örnek belge yükleme yöntemine ilişkin açıklama, cevabımın alt kısmındaki İMZA bölümünde var.
.

Sorunun örneklendiği resim


sorunun çözülmüş hali

 

[Ömer BARAN]

Çözümün kendisi yerine ekran görüntüsünü görseniz ne dersiniz?

Destek istiyorsunuz ama F12 tuşuna basıp gerçek belgenizin bir kopyasını aldıktan sonra
gereksiz/özel verileri silip CTRL+S tuşuna basarak örnek belge oluşturup bunu foruma eklemiyorsunuz.

Ama destek verecek kişiden;
-- istediğiniz özelliklere sahip veriler içeren belge oluşturmasını,
-- kodları oluşturmasını,
-- kodları denemesini,
-- çözüme ulaştıktan sonra da çözüm kodlarını göndermesini
istiyorsunuz.
.

 

[mkagan16]

Çözümün kendisi yerine ekran görüntüsünü görseniz ne dersiniz?

Destek istiyorsunuz ama F12 tuşuna basıp gerçek belgenizin bir kopyasını aldıktan sonra
gereksiz/özel verileri silip CTRL+S tuşuna basarak örnek belge oluşturup bunu foruma eklemiyorsunuz.

Ama destek verecek kişiden;
-- istediğiniz özelliklere sahip veriler içeren belge oluşturmasını,
-- kodları oluşturmasını,
-- kodları denemesini,
-- çözüme ulaştıktan sonra da çözüm kodlarını göndermesini
istiyorsunuz.
.

Çok özür dilerim yeniyim kusura bakmayın haklısınız.
örnek belge.xlsx - 1.2 MB

 

[Ömer BARAN]

Merhaba.

Sanırım forumda yeni olmanızdan kaynaklanıyor.
Aynı soru/konu için, mevcut bir konu sayfası varken yeni konu açmayınız.

FORUM YÖNETİCİLERİnden birine (ismi kırmızı renkli olanlar) özel mesaj yazarak diğer konunun silinmesini isteyiniz.
Sorunuzun cevabı aşağıda açıklandı.

=> Önce alt taraftan ilgili sayfanın adına sağ tıklayıp, "TAŞI veya KOPYALA"yı seçin, açılan küçük ekranda
alttaki KOPYA OLUŞTURun solundaki onay kutusunu işareleyin ve SONA TAŞIyı seçip işlemi onaylayın
(Mevcut sayfanın bir kopyası oluşturuldu ve işlem bu sayfa üzerinde gerçekleştirilecek. Maksat gerçek verilerinizin zarar görmemesi.)

=> Sonra alt taraftan bu kopya sayfanın adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
açılan VBA ekranında sağ taraftaki boş alana aşağıdaki kod'u yapıştırın,
OK tuşlarını kullanarak imleçin Sub SATIR_EKLE_BRN() satırına gelmesini sağlayın,
F5 tuşuna basın ve işlemin tamamlanmasını bekleyin.
.

[B]Sub SATIR_EKLE_BRN()[/B]
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Cells(Cells(Rows.Count, "E").End(3).Row + 1, "E") = [B][COLOR="Red"][SIZE="4"]23[/SIZE][/COLOR][/B]
For brn = Cells(Rows.Count, "E").End(3).Row - 1 To [B][COLOR="red"][SIZE="4"]2[/SIZE][/COLOR][/B] Step -1
[COLOR="red"][B]If Cells(brn, "E") = 23 And Cells(brn + 1, "E") = 0 Then GoTo 10
If Cells(brn, "E") = 0 And Cells(brn - 1, "E") = 23 Then GoTo 10[/B][/COLOR]
    If Cells(brn, "E") <> Cells(brn + 1, "E") - 1 Then
        Rows(brn + 1 & ":" & brn + 1).Insert
            If Cells(brn + 2, "E") = 0 Then Cells(brn + 1, "E") = 23
            If Cells(brn + 2, "E") > 0 Then Cells(brn + 1, "E") = Cells(brn + 2, "E") - 1
                Range(Cells(brn, "B"), Cells(brn, "D")).Copy Cells(brn + 1, "B")
                brn = brn + 1: End If
10: Next: Cells(Cells(Rows.Count, "E").End(3).Row, "E") = ""
For brn = 1 To Cells(Rows.Count, "E").End(3).Row
    If Cells(brn, "E") <> "" And Cells(brn, 2) = "" Then _
       Range(Cells(brn - 1, "B"), Cells(brn - 1, "D")).Copy Cells(brn, "B")
Next
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamamlandı.", vbInformation, "..::.. ÖMER BARAN ..::.."
[B]End Sub[/B]

 

[tahsinanarat]

Sn. Ömer Bey, örnek dosyada A ve F sütununu da bir üsteki ile doldurmak istersek, kodda nasıl bir değişiklik yapmalıyız.

 

[Ömer BARAN]

Sn. Ömer Bey, örnek dosyada A ve F sütununu da bir üsteki ile doldurmak istersek, kodda nasıl bir değişiklik yapmalıyız.

Merhaba.

Başka türlü de düzenlenebilirdi ama mevcut kod yapısını değiştirmeden cevaplamam gerekirse;
-- önceki kod'da kırmızı renklendirdiğim kısımı aşağıdaki ilk satır gibi değiştirip,
-- mavi olan satırı da hemen altına ekleyerek
istediğiniz sonuca varılabilir.
.

Range(Cells(brn - 1, "[B][COLOR="Red"][SIZE="4"]A[/SIZE][/COLOR][/B]"), Cells(brn - 1, "D")).Copy Cells(brn, "[B][COLOR="Red"][SIZE="4"]A[/SIZE][/COLOR][/B]")
[COLOR="Blue"]Cells(brn, "F") = Cells(brn-1, "F")[/COLOR]

 

[mkagan16]

Merhaba.

Sanırım forumda yeni olmanızdan kaynaklanıyor.
Aynı soru/konu için, mevcut bir konu sayfası varken yeni konu açmayınız.

FORUM YÖNETİCİLERİnden birine (ismi kırmızı renkli olanlar) özel mesaj yazarak diğer konunun silinmesini isteyiniz.
Sorunuzun cevabı aşağıda açıklandı.

=> Önce alt taraftan ilgili sayfanın adına sağ tıklayıp, "TAŞI veya KOPYALA"yı seçin, açılan küçük ekranda
alttaki KOPYA OLUŞTURun solundaki onay kutusunu işareleyin ve SONA TAŞIyı seçip işlemi onaylayın
(Mevcut sayfanın bir kopyası oluşturuldu ve işlem bu sayfa üzerinde gerçekleştirilecek. Maksat gerçek verilerinizin zarar görmemesi.)

=> Sonra alt taraftan bu kopya sayfanın adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
açılan VBA ekranında sağ taraftaki boş alana aşağıdaki kod'u yapıştırın,
OK tuşlarını kullanarak imleçin Sub SATIR_EKLE_BRN() satırına gelmesini sağlayın,
F5 tuşuna basın ve işlemin tamamlanmasını bekleyin.
.

[B]Sub SATIR_EKLE_BRN()[/B]
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Cells(Cells(Rows.Count, "E").End(3).Row + 1, "E") = 24
For brn = Cells(Rows.Count, "E").End(3).Row - 1 To 1 Step -1
If Cells(brn, "E") = 23 And Cells(brn + 1, "E") = 0 Then
    brn = brn - 1: GoTo 10: End If
    If Cells(brn, "E") <> Cells(brn + 1, "E") - 1 Then
        Rows(brn + 1 & ":" & brn + 1).Insert
            If Cells(brn + 2, "E") = 0 Then Cells(brn + 1, "E") = 23
            If Cells(brn + 2, "E") > 0 Then Cells(brn + 1, "E") = Cells(brn + 2, "E") - 1
                Range(Cells(brn, "B"), Cells(brn, "D")).Copy Cells(brn + 1, "B")
                brn = brn + 1: End If
10: Next: Cells(Cells(Rows.Count, "E").End(3).Row, "E") = ""
For brn = 1 To Cells(Rows.Count, "E").End(3).Row
    If Cells(brn, "E") <> "" And Cells(brn, 2) = "" Then _
       [COLOR="Red"]Range(Cells(brn - 1, "B"), Cells(brn - 1, "D")).Copy Cells(brn, "B")[/COLOR]
Next
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamamlandı.", vbInformation, "..::.. ÖMER BARAN ..::.."
[B]End Sub[/B]

Hocam çok teşekkür ederim çok sağolun. Verdiğiniz kod ile beni büyük bir uğraştan kurtardınız.
Fakat kod sadece tek bir yerde sıkıntı çıkarıyor. E sütununda 21 den sonra 23 olan hücreleri yakalayamıyor. Onun dışında hiç bir problemi yok.

 

[Ömer BARAN]

Tekrar merhaba.
Önceki kod cevabımı güncelledim.

Değişen kısımlarını kırmızı renklendirerek işaretledim.

Yeni halini deneyerek geri bildirimde bulunursunuz.
.

 

[tahsinanarat]

Sn. Ömer Hocam; a sutunu tamam ancak f sutunu olmadı.

 

[Ömer BARAN]

Sn. Ömer Hocam; a sutunu tamam ancak f sutunu olmadı.

Kod'da aşağıdaki kısmı düzeltmeniz lazım.
If satırının sonundaki ALT TİRE işareti dikkatimden kaçmış.
Koşul gerçekleştiğinde yapılacak işlem 1 tane olduğundan,
ALT TİRE işaretiyla alttaki satırı da aynı satıra bağladığım için End If satırı kullanmamamıştım.
Ancak F sütunu için ikinci bir işlem gerektiğinden ALT TİREnin kaldırılması ve End If satırının eklenmesi gerekiyordu.
.

[B]Önceki:[/B]
[COLOR="blue"]    [B]If[/B] Cells(brn, "E") <> "" And Cells(brn, 2) = "" Then [B][COLOR="Red"][SIZE="4"]_[/SIZE][/COLOR][/B]
       Range(Cells(brn - 1, "B"), Cells(brn - 1, "D")).Copy Cells(brn, "B")
[/COLOR]

[B]Yenisi:[/B]
    [B]If[/B] Cells(brn, "E") <> "" And Cells(brn, 2) = "" Then
       Range(Cells(brn - 1, "[B][COLOR="Red"][SIZE="4"]A[/SIZE][/COLOR][/B]"), Cells(brn - 1, "D")).Copy Cells(brn, "[B][COLOR="Red"][SIZE="4"]A[/SIZE][/COLOR][/B]")
       Cells(brn-1, "F").Copy Cells(brn, "F")
    [B]End If[/B]

 

[Ömer BARAN]

Bu arada. Sayın mkagan16 için; 6 numaralı cevaptaki kod'da güncelleme yaptığımı bir kez daha hatırlatayım.

 

[tahsinanarat]

Sn. Ömer Hocam; Numarası olup eksik olan hücreleri üstteki bilgilerle tamamlanıyor (f sutunu da dahil)
saadece eksik olan satırları tamamladığında a sütununda d sütununa kadar bilgileri tamamlıyor f sütunundaki bilgiler tamamlamıyor, bilginiz olsun. Emeğinize sağlık çok teşekkürler hocam.

 

[Ömer BARAN]

3 numaralı cevapta yer alan ekran görüntüsüne göre konu sahibinin isteği;
E sütununa göre 0-23 arasında eksikleri tamamlamak,
eklenen satırlarda, B, C ve D sütunlarına bir üst satırdaki verilerin aynen yazılması şeklinde.
(yani A ve F sütununda eksik tamamlama veya üstteki veriyi yazma isteği yok)

6 numaralı cevapta verdiğim kod (bu sabah o kod'da bir eksiği tamamlayan düzeltme yapmıştım)
yanlış görmüyorsam, konu sahibinin bu isteğini tam olarak karşılıyor.

Sn. Ömer Bey, örnek dosyada A ve F sütununu da bir üsteki ile doldurmak istersek, kodda nasıl bir değişiklik yapmalıyız.

12 numaralı cevaptaki (8 numaralı cevaptaki hatalı önerimin düzeltmesi) kod ise, sizin yukarıdaki sorunuzun karşılığı olarak verdiğim cevap idi.

 

[mkagan16]

Bu arada. Sayın mkagan16 için; 6 numaralı cevaptaki kod'da güncelleme yaptığımı bir kez daha hatırlatayım.

Hocam daha yeni deneme fırsatım oldu.Çok teşekkür ederim.Cevabınız tam istediğim gibi her şeyi karşılıyor. Büyük bir dertten kurtardınız beni.