• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Farklı kelimelerin arasına 3 satır ekleme

C

cengiz123

Katılım
25 Mart 2017
Mesajlar
177
Excel Vers. ve Dili
2013
Merhaba arkadaşlar
A sütünün da aşağıdaki gibi değerler var. İsteğim farklı kelimeler arasında 3 satır eklemesi.
Ancak makro da satır ekle komutunu kullanınca işlem çok yavaş oluyor.
Bunu satır ekleme komutundan hariç, farklı bir fonksiyonla yapılabilir mı?
A
Comand1
Comand1
Comand1
Comand2
Comand2
Comand3
Comand3
Comand3
Comand3
Comand4
Comand4
Comand5
 
Örnek dosya eklerseniz.
 
Şuan bilgisayarım yanımda yok. Küsura banmayın.
Satır ekle komutu yapmadan yukarıdaki a sütununa nasıl satır ekleyebiliriz. Command1 ile 2 arasına 3 satır, aynı şekilde diğerlerinede. Tabi bu command1 örnek.
İki satır arası değer değiştiğinde araya 3 boşluk ekleyecek.
Umarım anlatabilmisimdir derdimi
 
Aşağıdaki kodları kullanabilirsiniz. Yaklaşık 13000 veri için 30 sn gibi bir süre sürdü.
Kod: 
Sub askm()
Dim SonSat As Long
SonSat = Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For i = SonSat To 2 Step -1
    If Cells(i, 1) <> Cells(i - 1, 1) Then
        Rows(i).Insert Shift:=xlDown
        Rows(i).Insert Shift:=xlDown
        Rows(i).Insert Shift:=xlDown
        i = i - 1
    End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub
 
Bende ki kodda bu şekilde ama satıt fazla olunca çok uzun sürüyor.
Başka bir yolu yok mudur hocam bunun?
 
Merhaba,

Bu şekilde deneyin.

Kod: 
Sub satir3()
a = Range("A2:A" [COLOR="Red"]& Cells(Rows.Count, 1).End(3).Row[/COLOR])
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(a): d(a(i, 1)) = "": Next i
On Error Resume Next
ReDim b(1 To UBound(a) + (d.Count) * 3, 1 To 1)
For i = 1 To UBound(a)
    say = say + 1
    b(say, 1) = a(i, 1)
    If a(i, 1) <> a(i + 1, 1) Then
        say = say + 3
    End If
Next i
[A2].Resize(say - 3) = b
MsgBox "İşlem tamam", vbInformation
End Sub
 
Ziynettin Hocam merhaba
13000verilik bir dosya askm hocanın dediği gibi 30 sn civarı sürüyordu.
Sizin kodunuz 1sn sürüyor.çok hızlı.
Yalnız son hücre bul satırını 3le çarp dedim. Son kısımları almıyordu.bu şekliyle hepsinin arasına 3 satır ekliyor.
Kod mükemmel hızlı. Çok teşekkür ederim
Bir sorum daha olacaktı.
A sütununa baktı 3 satır ekledi. Yalnız b,c,d,e,f,g dede veriler var. Onların da arasına 3 satırı aynı şekilde eklettirebilir miyiz.
 
...

[A:G] aralığı için,
Kod: 
Sub satir_ac()
a = Range("A2:G" & Cells(Rows.Count, 1).End(3).Row)
On Error Resume Next
For i = 1 To UBound(a)
    If a(i, 1) <> a(i + 1, 1) Then
        n = n + 1
    End If
Next i

ReDim b(1 To UBound(a) + (n - 1) * 3, 1 To UBound(a, 2))
For i = 1 To UBound(a)
    say = say + 1
    For j = 1 To UBound(a, 2)
        b(say, j) = a(i, j)
    Next j
    If a(i, 1) <> a(i + 1, 1) Then
        say = say + 3
    End If
Next i
[A2].Resize(say - 3, UBound(a, 2)) = b
MsgBox "İşlem tamam", vbInformation
End Sub
 
Son düzenleme:
Merhaba Ziynettin hocam
Çok teşekkürler. Elinize sağlık.
En son satırlarda veri kaybolıyor ve #yok yazıyor
Cells(Rows.Count, 1).End(3).Row kısmını *3 yaptım. Doğru bir çözüm müdür acaba
 
Ziynettin hocam. Elinize sağlık. Allah razı olsun.
#yok hatası da gelmiyor.
Yani bu kadar hızlı çalışacağını hayal dahi edemiyordum.
Size zahmet, kodu bize de anlatsanızda ilerde benzer durumlarda kullanırız
 
Ziynettin hocam
Kodu bir makronun içinde kullanınca
Ubound(a) da hata veriyor.
Bir kodunun arasında kullanamaz mıyız bunu
 
Kullandığınız şarta bağlı.

a() dizi tipi. "a başka değer de olabilir.
Ubound(a) dizinin son satır numarası.
Ubound(a,2) dizinin son sutun numarası.

Nasıl kod yazdığınızı paylaşırsanız hata nedenine bakalım.
 
Merhaba Ziynettin hocam
Kodunuz çok hızlı ve güzel çalışıyor.
Kodun içinde çalışmamasının nedeni integer olarak onu tanımlamışım. O yüzden hata vermiş.

Ancak bazen ilk 9 satırın aralarına 3er satır eklemiyor

İkinci yavaş çalışan bir kodum daha var.
Size zahmet yardımcı olur musunuz.
C sütünununda her satırda başka değerler var.
Örneğin c sütununda hücre değeri comport'sa bir altına yeni satır ekle.
Bunu for döngüsü ve if'le yaptım.
Rows(x).Insert Shift:=xlDown özelliğini kullanarak yeni satır oluşturdum.
Ancak 2000-3000 satır olunca çok yavaş çalışıyor.
Yukarıdaki hızlı kodunuzu bu bahsettiğim konuya da uyarlayabilir mısınız?
Size de çok zahmet verdim. Ne kadar teşekkür etsem az
 
Son düzenleme:
Merhaba,

Ancak bazen ilk 9 satırın aralarına 3er satır eklemiyor
Genişletmek için tıkla ...

Kodda sorun yok dosyanızı ekleyin bakalım.




c sütununda hücre değeri comport'sa bir altına yeni satır ekle.
Genişletmek için tıkla ...

A:G aralığında C sutununda comport bulunan satırdan sonra bir satır aşağıya kaydırır. Bunu yapmak istiyorsunuz.

Kod: 
Sub deneme()
a = Range("A2:G" & Cells(Rows.Count, 1).End(3).Row)
On Error Resume Next
For i = 1 To UBound(a)
    If a(i, 3) = "comport" Then
        n = n + 1
    End If
Next i

ReDim b(1 To UBound(a) + n, 1 To UBound(a, 2))
For i = 1 To UBound(a)
    say = say + 1
    For j = 1 To UBound(a, 2)
        b(say, j) = a(i, j)
    Next j
    If a(i, 3) = "comport" Then
        say = say + 1
    End If
Next i
[A2].Resize(say, UBound(a, 2)) = b
MsgBox "İşlem tamam", vbInformation
End Sub
 
Merhaba Ziynettin hocam
Benim makro kodlar hatalı olduğu için kodunuz çalışmamış.
Sizin ikinci kodda harika çalışıyor.

Son kez daha rahatsız edecem.
Yukarıdaki kod gibi c sütununda yazılı hücreler var.
J ve k sütununda da yazılı hücreler var. Bu j sütunundaki yazılarının bazılarının karşısında (k sütununda) 2 yazıyor.
Eğer k sütünün da 2 yazıyorsa ;
J sütunundaki değerleri c sütununda bulursa a-g satırı bir sıra aşağı kaydıracak(1 boşluk bırakacak)
Kusura bakmayın sorularım için
 
Ziynettin hocam
Altına bir satır boşluk açınca, bir üstteki satırı yeni oluşan alt satıra da kopyalaması gerekir.
 
Cengiz Bey,

Kısa örnek ve nasıl olmasını istediğiniz dosya ekleyin bu şekilde varsayımlarla bir sonuca varmayız.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst