Aynı satırdaki iki sayının arasını başka satırda doldurma

[euphrates55]

Aynı satırdaki iki sayının ya da sayı olmayabilir yazı olabilir harf olabilir, arasını başka satırda araları dolacak şekilde formülize etmek istiyorum.

 

[euphrates55]

durumu kod ile çözebiliyorum ama 300 satıra 600 sütunluk bir alan içerisinde ana tablomu düşündüğümde çok uzun sürüyor. kodu da bırakayım belki daha kısa bir çözüm öneriniz olabilir. ama formülle çözümü varsa bana daha uygun olacaktır. sonuçta boş satırlarda oluyor ve her hücre sorgulanınca makro 8-9 dk sürüyor.

Sub analiz()
Application.ScreenUpdating = False
On Error Resume Next
Range("c20:t23").ClearContents 
For i = 5 To 8       
For k = 3 To 20   
If Cells(i, k) <> "" Then
yazılacak = Cells(i, k)
ilk = k
For Z = k + 0 To 20
If Cells(i, Z) = yazılacak Then ikincisi = Z
Next Z
For yazz = ilk To ikincisi
Cells(i + 15, yazz) = yazılacak
Next yazz
End If
Next k
Next i
Application.ScreenUpdating = True
MsgBox "İşlem TAMAM.", vbInformation
End Sub

 

[ÖmerBey]

Merhaba,
Bir de aşağıdaki kodu deneyiniz...

Sub kod()
Dim a As Integer, b As Integer
Dim dz As Variant
Dim yazkont As Boolean
Dim yaz As String

Range("C20:T23").ClearContents
dz = Range("C5:T8")
For a = LBound(dz) To UBound(dz)
    For b = LBound(dz, 2) To UBound(dz, 2)
        If dz(a, b) <> "" Then
            yazkont = Not yazkont
            yaz = dz(a, b)
        End If
        If yazkont = True Then dz(a, b) = yaz
    Next
Next
Range("C20").Resize(UBound(dz), UBound(dz, 2)).Value = dz
End Sub

Formül kullanmak isterseniz de C20'ye aşağıdaki formülü uygulayıp sağa ve aşağı çekerek çoğaltınız.

=EĞER(BAĞ_DEĞ_DOLU_SAY($C5:C5)=1;EĞER(C5="";B20;C5);EĞER(C5="";"";C5))

 

[euphrates55]

Merhaba,
Bir de aşağıdaki kodu deneyiniz...

Sub kod()
Dim a As Integer, b As Integer
Dim dz As Variant
Dim yazkont As Boolean
Dim yaz As String

Range("C20:T23").ClearContents
dz = Range("C5:T8")
For a = LBound(dz) To UBound(dz)
    For b = LBound(dz, 2) To UBound(dz, 2)
        If dz(a, b) <> "" Then
            yazkont = Not yazkont
            yaz = dz(a, b)
        End If
        If yazkont = True Then dz(a, b) = yaz
    Next
Next
Range("C20").Resize(UBound(dz), UBound(dz, 2)).Value = dz
End Sub

Formül kullanmak isterseniz de C20'ye aşağıdaki formülü uygulayıp sağa ve aşağı çekerek çoğaltınız.

=EĞER(BAĞ_DEĞ_DOLU_SAY($C5:C5)=1;EĞER(C5="";B20;C5);EĞER(C5="";"";C5))

elinize bilginize sağlık, teşekkürler. geç cevap verdiğim için de kusuruma bakmayın lütfen.

 

[ÖmerBey]

Rica ederim,
İyi çalışmalar...

 

[euphrates55]

@ÖmerBey bir yerde sorun oluşuyor. bu örnek için itinerer sekmesinde 671. satırdan sonra farklı sonuçlar veriyor. bakma şansınız var mı?

 

[euphrates55]

günler sonra sorunun makrodan değil benden kaynaklandığını çözdüm. tabloda bir aralık içerisinde her bir hücreye bir birim gözüyle bakınca bazı değerler sadece bir hücreye denk geliyor. dolayısı ile satır içerisinde iki değer değil tek değer oluyor. dolayısı ile makro da 2. değeri bulamayınca yapması gerekeni yapıyor ama benim için yanlış oluyordu. bu tür satırların değerini sıfır yazarak durumu geçiştirdim. çünkü mantıken zaten çok küçük bir arlığa denk geliyor olacaktır. tekrar teşekkürler.

 

[ÖmerBey]

Ben de günler sonra aşağıdaki şekilde bir çözüm önerisi sunabilirim sanıyorum.
Kırmızı kısmı kodunuza ilave ederseniz satırlar arası bir aktarım olmasını engelleyebilirsiniz. Dilerseniz tek değer içeren satırlarda işlem yapılmaması için de ayrı bir kontrol döngüsü eklenebilir.

For a = LBound(dz) To UBound(dz)
    yazkont = False
    For b = LBound(dz, 2) To UBound(dz, 2)

 

[euphrates55]

Ben de günler sonra aşağıdaki şekilde bir çözüm önerisi sunabilirim sanıyorum.
Kırmızı kısmı kodunuza ilave ederseniz satırlar arası bir aktarım olmasını engelleyebilirsiniz. Dilerseniz tek değer içeren satırlarda işlem yapılmaması için de ayrı bir kontrol döngüsü eklenebilir.

For a = LBound(dz) To UBound(dz)
    yazkont = False
    For b = LBound(dz, 2) To UBound(dz, 2)

siz zaten büyük kısmı çözdünüz. küçük kısmı da ben çözmüş oldum. iyi çalışmalar.

 

[euphrates55]

Ben de günler sonra aşağıdaki şekilde bir çözüm önerisi sunabilirim sanıyorum.
Kırmızı kısmı kodunuza ilave ederseniz satırlar arası bir aktarım olmasını engelleyebilirsiniz. Dilerseniz tek değer içeren satırlarda işlem yapılmaması için de ayrı bir kontrol döngüsü eklenebilir.

For a = LBound(dz) To UBound(dz)
    yazkont = False
    For b = LBound(dz, 2) To UBound(dz, 2)

şöyle bir şey olabilir mi peki. tek hücrede değer varsa, yani herhangi bir aralık olmuyorsa; sadece tek hücrenin değerini ilgili hücreye yazdırabilir miyiz? boş kalmasın

 

[ÖmerBey]

Kontrol döngüsü ilavesiyle yeni döngü aşağıdaki şekilde olabilir. Yeni eklenenler kırmızı renkle gösteriliyor.
Dosyanıza uyarlayıp deneyiniz...

For a = LBound(dz) To UBound(dz)
    say = 0
    For b = LBound(dz, 2) To UBound(dz, 2)
        If dz(a, b) <> "" Then
            say = say + 1
            If say = 2 Then GoTo 1 'Satırda 2 dolu değer varsa sonraki döngüye git
        End If
    Next
    GoTo 2 'Satırda 2 dolu değer olmadığı durumda bu satırı pas geç, yani değişiklik yapma
1
    For b = LBound(dz, 2) To UBound(dz, 2)
        If dz(a, b) <> "" Then
            yazkont = Not yazkont
            yaz = dz(a, b)
            If yazkont = False Then Exit For 'Dosyanızdaki tek bir satıra birden fazla aralık girilecekse ise bu kodu siliniz.
        End If
        If yazkont = True Then dz(a, b) = yaz
    Next
2
Next