Satır Çoğaltma

[dursuni]

Merhaba excel dosyası ekleyemiyorum, onun için buradan isteğimi anlatmaya çalışacağım Bir excel dosyasında, illere bağlı ilçeler, Üye sayısı ve İşlem hacmi satırları mevcut. Ben bu listeyi genişletmek istiyorum ama tüm Türkiye'yi kapsadığı için tek tek elle çoğaltmk zor olacak. Bunun için yardımlarınızı bekliyorum.

Şimdiden teşekkürler....



Talep:

İlçe Üye Sayısı İş Hacmi
ALADAĞ 2 125
CEYHAN 2 744
YUMURTALIK 2 84
YÜREĞİR 4 1,705
ADIYAMAN 2 865
TUT 2 10
AFYON 4 1,526
ADALAR 2 60
ARNAVUTKÖY 2 449
ESENYURT 9 4,046
EYÜP 4 1,784
FATİH 2 730
GAZİOSMANPAŞA 3 1,403
GÜNGÖREN 2 382
KADIKÖY 4 1,538
KAĞITHANE 5 2,358
ZEYTİNBURNU 3 1,102
ALİAĞA 2 625
BALÇOVA 2 190
BAYINDIR 2 452
AKYAKA 2 43
ARPAÇAY 2 64

Yukarıdaki listede ilçeye karşılık gelen Üye sayısı sütunundaki sayı kadar satır ekleyip içine aynı verileri yazmak istiyorum. Mesela İstanbul Kağıthane için Üye Sayısı 5 adet gözüküyor. Ben İstanbul Kağıthane altına 4 adet daha aynı satırdan eklemek istiyorum. Yani toplamda 5 Üye olmasını sağlayacağım. Aynı şekilde Adana Aladağ İlçesi için Üye sayısı 2 gözüküyor. Ben o satırın altına aynısından kopyalamak istiyorum.

 

[asi_kral]

Merhaba
Boş bir module kopyalayın ve deneyin.

Option Explicit
Sub satır_ekle()
Dim STR As Long
For STR = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
If Cells(STR, "A") <> Cells(STR - 1, "A") Then
If Cells(STR, "B") > 1 Then
Rows(STR + 1 & ":" & STR + Cells(STR, "B") - 1).Insert shift:=xlDown
Range("A" & STR & ":A" & STR + Cells(STR, "B") - 1) = Cells(STR, "A")
End If: End If
Next
End Sub

 

[halit3]

Alternatif kod

Kodun işlevi A,B,C sütünlarındaki bilgiler doğrultusunda işlem yapmaktadır.
Başlangıç satır A2 dir.

A1 (İlçe) B1(Üye Sayısı) C1(İş Hacmi)

A2(ALADAĞ) B2(2) C2(125)

Yukarıdaki işlemi aşağıda şöyle yapmaktadır.

A2(ALADAĞ) B2(2) C2(125)
A3(ALADAĞ) B3(2) C3(125)
A4(ALADAĞ) B4(2) C4(125)

Sub Satirekle()

Dim i As Long, j As Long

Application.ScreenUpdating = False

For i = [a65536].End(3).Row To 2 Step -1
sayi = Val(Cells(i, 2).Value)
If sayi > 0 Then
For j = 1 To sayi
Rows(i + 1).Insert Shift:=xlDown
Cells(i + 1, 1).Value = Cells(i, 1).Value
Cells(i + 1, 2).Value = Cells(i, 2).Value
Cells(i + 1, 3).Value = Cells(i, 3).Value
Next
End If
Next i

Application.ScreenUpdating = True
MsgBox "İşlem Tamam...."
End Sub

 

[Necdet]

Merhaba,

Bir kod da benden olsun, xl nin olanaklarını kullanarak tüm satırların kopyasını çıkarttım. Bende Halit bey gibi anladım soruyu.

Sub Makro1()
    
    Dim i   As Long
    Dim Son As Long
    Dim Adt As Integer
    
    Application.ScreenUpdating = False
    
    Son = Cells(Rows.Count, "A").End(3).Row
    Adt = Cells(Son, "B") - 1
    
    For i = Son To 2 Step -1
    
        If Cells(i, "B") > 1 Then Rows(i + 1 & ":" & i + Cells(i, "B") - 1).Insert Shift:=xlDown
    
    Next i
    
    i = Cells(Rows.Count, "A").End(3).Row + Adt
    
    With Range("A2:C" & i)
        .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
        .Copy
        .PasteSpecial Paste:=xlPasteValues
    End With
    
    Range("A1").Select
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
    
    MsgBox "İşlem Tamamlanmıştır....."
    
End Sub

 

[hamitcan]

Bir tane de benden.

Sub SatirCogalt()
    For i = [a65536].End(3).Row To 2 Step -1
        s = Cells(i, 2) - 1
        Rows(i + 1 & ":" & i + s).Insert
    Next
        Columns("A:C").Select
        Selection.SpecialCells(xlCellTypeBlanks).Select
        [a3].Activate
        Selection.FormulaR1C1 = "=R[-1]C"
        MsgBox "Bitti"
End Sub

 

[Murat OSMA]

Alternatif;

Sub İstenilen_Sayı_Kadar_Satir_Ekle()
    Dim a As Byte, sat As Byte
    [A3].Select
    While ActiveCell.Value <> ""
    a = ActiveCell.Offset(-1, 1).Value + 1: sat = ActiveCell.Offset(-1, 1).Value
        ActiveSheet.Rows(ActiveCell.Row & ":" & _
        sat + ActiveCell.Row - 1).Insert Shift:=xlDown
        ActiveCell.Offset(a, 0).Select
    Wend
    a = Empty: sat = Empty
End Sub

 

[dursuni]

Alternatif kod

Kodun işlevi A,B,C sütünlarındaki bilgiler doğrultusunda işlem yapmaktadır.
Başlangıç satır A2 dir.

A1 (İlçe) B1(Üye Sayısı) C1(İş Hacmi)

A2(ALADAĞ) B2(2) C2(125)

Yukarıdaki işlemi aşağıda şöyle yapmaktadır.

A2(ALADAĞ) B2(2) C2(125)
A3(ALADAĞ) B3(2) C3(125)
A4(ALADAĞ) B4(2) C4(125)

Sub Satirekle()

Dim i As Long, j As Long

Application.ScreenUpdating = False
'For i = 1 To 200 Step 4
For i = [a65536].End(3).Row To 2 Step -1
sayi = Val(Cells(i, 2).Value)
If sayi > 0 Then
For j = 1 To sayi
Rows(i + 1).Insert Shift:=xlDown
Cells(i + 1, 1).Value = Cells(i, 1).Value
Cells(i + 1, 2).Value = Cells(i, 2).Value
Cells(i + 1, 3).Value = Cells(i, 3).Value
Next
End If
Next i

Application.ScreenUpdating = True
MsgBox "İşlem Tamam...."
End Sub

Tüm yardım etmeye çalışan arkadaşlara teşekkürler.
İstediğimi Halit Bey'in verdiği makro çözdü. Diğer arkadaşların verdiği kodları denemedim ama onlarda çözüm üretecektir elbet.

Tekrar teşekkürler...

 

[Necdet]

Tüm yardım etmeye çalışan arkadaşlara teşekkürler.
İstediğimi Halit Bey'in verdiği makro çözdü. Diğer arkadaşların verdiği kodları denemedim ama onlarda çözüm üretecektir elbet.

Tekrar teşekkürler...

Her kod farklı mantıkla yapılmış. Kimisi yavaş çalışır kimisi hızlı.

Bir deneseydiniz, o kadar kişinin emeği boşa gitmesin değil mi?

 

[benazio1]

boş satırları doldurma

arkadaşlar aşağıdaki gibi listelerim oluyor
a ve b sutunundaki boşlukları üstteki dolu hücreye göre doldurmam gerekiyor
ben makro kaydetten bu şekilde bir makro kaydettim fakat her boşluk için makroyu yeniden çalıştırmam gerekiyor
bunu tek seferde yapabilecek bir makro yazılabilirmi
yardımcı olabilirmisiniz

1492 1 22X 1450
22X 1500
1493 1 22X 1600
22X 7500
1494 1 22X 1625
22X 7600
32X 3800
32X 4175
32X 8000
1495 1 22X 1650
22X 4000
1496 1 22X 1700
22X 4050

 

[YUSUF44]

arkadaşlar aşağıdaki gibi listelerim oluyor
a ve b sutunundaki boşlukları üstteki dolu hücreye göre doldurmam gerekiyor
ben makro kaydetten bu şekilde bir makro kaydettim fakat her boşluk için makroyu yeniden çalıştırmam gerekiyor
bunu tek seferde yapabilecek bir makro yazılabilirmi
yardımcı olabilirmisiniz

1492 1 22X 1450
22X 1500
1493 1 22X 1600
22X 7500
1494 1 22X 1625
22X 7600
32X 3800
32X 4175
32X 8000
1495 1 22X 1650
22X 4000
1496 1 22X 1700
22X 4050

Örnek dosya olsaydı daha iyi olurdu. Aşağıdaki kodları bir modüle kopyalayıp deneyiniz:

Sub doldur()
son = WorksheetFunction.Max(Cells(Rows.Count, "A").End(3).Row, Cells(Rows.Count, "B").End(3).Row)
For i = 2 To son
    If Cells(i, "A") = "" Then
        Cells(i, "A") = Cells(i - 1, "A")
    End If
    If Cells(i, "B") = "" Then
        Cells(i, "B") = Cells(i - 1, "B")
    End If
Next
End Sub

 

[benazio1]

Yusuf bey
çok teşekkür ederim
tam istediğimi karşıladı