araya eksik sayıyı satır girerek ekleme

[kttpci]

İyi günler:

9000 satırda 1 den 10000 e kadar sırasıyla sayılmış sayılar var(ikinci sütunda da o sayının ilgili verileri var). Aradaki sayı boşluklarını (örnek 75 den 82 ye geçmiş ) satır ekletip sırasıyla doldurarak 10000 e tamamlamak istiyorum.Yardım edebilirmisiniz.

 

[muygun]

Merhaba;
Eki inceleyin.

Not: Orjinal verilerinize geri dönebilmek için farklı sayfada işlem yaptım.
Sonuç sizin için yeterliyse sonuç sayfasında A:B sütununu kopyalayıp milas sayfasında A sütununa yapıştırabilirsiniz.
nolu mesaja göre ekli dosya yeniden düzenlendi.


İyi çalışmalar.

 

[Ömer]

Merhaba,

Alternatif olsun, yalnız kodu çalıştırmadan önce 801. satırın tümünü ( 891,7 olan veriyi ) ve son satır olan 8961 satındaki veriden ( 10222, ) başlayarak yani 8961:65536 satırlarını silmeniz gerekir. Buradaki ondalık sayı, sayı olmayan ve tanımsız değerler hatalı sonuçlar üretmektedir.

Sub EkleKopyala()
Application.ScreenUpdating = False
Dim i As Double
Dim Say As Integer
For i = [A65536].End(3).Row To 3 Step -1
    Say = Cells(i, "A") - Cells(i - 1, "A")
    If Say <> 1 Then
        Say = Say - 2
        Rows(i & ":" & i + Say).Insert Shift:=xlDown
     End If
Next i
Dim s As Integer
For j = 2 To [A65536].End(3).Row
    s = s + 1
    Cells(j, "a") = s + 1
       If Cells(j, 2) = "" Then
           Cells(j - 1, 2).Copy
           Cells(j, 2).PasteSpecial
           Application.CutCopyMode = False
       End If
Next j
Application.ScreenUpdating = True
End Sub

.

 

[kttpci]

merhaba
sayın muygun
Gönderdiğin dosya baya işimi gördü sağolasın.
Fakat iki sütunu silmiştim.Onlarıda sıralamaya dahil edebilirmisin.

 

[kttpci]

Sayın Ömer
Cevap verdiğin için sağol.
Söylediğin satırları sildim ve kodu çalıştırdım.Sıralama ve ekleme yaptı , fakat eklenen satırlara bir üstteki satırın aynısını kopyalıyor.Mesela 35,36,37 eklenen satırlara 34. de bulunan bilgileri kopyalıyor.Boş olmasını istiyorum.
Bu arada Kodun güzel yazılmış.

 

[Ömer]

8601 ve 8602 satırlarında aynı veri olduğu için bu satırlardan birini sildikten sonra kodları çalıştırınız..

Sub EkleKopyala()
Application.ScreenUpdating = False
Dim i As Double
Dim Say As Integer
For i = [A65536].End(3).Row To 2 Step -1
    Say = Cells(i, "A") - Cells(i - 1, "A")
    If Say <> 1 Then
        Say = Say - 2
        Rows(i & ":" & i + Say).Insert Shift:=xlDown
     End If
Next i
Dim s As Integer
For j = 1 To [A65536].End(3).Row
    s = s + 1
    Cells(j, "a") = s
Next j
Application.ScreenUpdating = True
End Sub

.

 

[muygun]

merhaba
sayın muygun
Gönderdiğin dosya baya işimi gördü sağolasın.
Fakat iki sütunu silmiştim.Onlarıda sıralamaya dahil edebilirmisin.

Merhaba;
2 Nolu mesaj ekini yeniledim.
Ayrıca hs sayfasındaki formülleri çoğaltmanız gerekiyor. gerekli açıklama ilgili sayfada.
İyi çalışmalar.