Aynı olan bilgileri butonla aktarma

[ASLAN7410]

Merhaba arkadaşlar hayırlı geceler.

Ekte bir excel çalışmam var, yapmak istediğimi sayfa üzerine yazdım, yardımcı olacak arkadaşlara şimdiden çok teşekkür ederim.

Makro yazmaktan anlamadığım için yapamadım.

 

[Ömer BARAN]

Merhaba.

ALT+F11 tuşlarına basarak VBA ekranını açın, üstteki INSERT menüsünden MODULEyi seçin,
sağ taraftaki boş alana aşağıdaki kod'u yapıştırın ve F5 tuşuna basın.
.

[FONT="Arial Narrow"]Sub aktar_boşluklu()
Set s1 = Sheets("Sayfa1"): Set s2 = Sheets("Sayfa2")
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
zaman = Timer
If s2.[A65536].End(3).Row > 1 Then s2.Rows("2:65536").Delete Shift:=xlUp
s2.Activate: s2.Cells.UnMerge
s1.Range("A40:M" & s1.[A65536].End(3).Row).Copy: s2.[B2].PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
s2.Range("A2:N" & s2.[E65536].End(3).Row).Sort Range("E2"), xlAscending
With s2.Range("A2:N" & s2.[B65536].End(3).Row)
    .Font.Size = 10: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter
End With
With s2.Range("A2:A" & [B65536].End(3).Row)
    .Formula = "=COUNTIF($E$2:E2,E2)": .Value = .Value
End With
s2.[A1].Activate: son = [A65536].End(3).Row + (WorksheetFunction.CountIf(s2.Range("A:A"), 1) * 4) - 1
For sat = 3 To son
10: If s2.Cells(sat, 1) = 1 Then
    s2.Rows(sat & ":" & sat + 3).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    s2.Range("A1:N1").Copy s2.Cells(sat + 3, 1)
    adet = WorksheetFunction.CountIf(s2.Range("E2:E" & sat - 1), Cells(sat - 1, 5))
    s2.Range(s2.Cells(sat + 1, 1), s2.Cells(sat + 1, 14)).Merge: s2.Rows(sat + 1 & ":" & sat + 1).RowHeight = 37.5
    s2.Cells(sat + 1, 1) = s2.Cells(sat - 1, 3) & " numaralı istasyon ile " & s2.Cells(sat - 1, 5) & _
    " numaralı istasyon arasında " & s2.Cells(sat - 1, 1) & " adet ölçüm yapılmıştır."
    s2.Cells(sat + 1, 1).Font.Size = 12: s2.Cells(sat + 1, 1).Font.Color = vbRed: sat = sat + 4
End If
Next
s2.Cells(s2.[A65536].End(3).Row + 2, 1) = s2.Cells(s2.[A65536].End(3).Row, 3) & _
    " numaralı istasyon ile " & s2.Cells(s2.[A65536].End(3).Row, 5) & _
    " numaralı istasyon arasında " & s2.Cells(s2.[A65536].End(3).Row, 1) & " adet ölçüm yapılmıştır."
s2.Range(s2.Cells(s2.[A65536].End(3).Row, 1), s2.Cells(s2.[A65536].End(3).Row, 14)).Merge
s2.Rows(s2.[A65536].End(3).Row & ":" & s2.[A65536].End(3).Row).RowHeight = 37.5
s2.Cells(s2.[A65536].End(3).Row, 1).Font.Size = 12
s2.Cells(s2.[A65536].End(3).Row, 1).Font.Color = vbRed: sat = sat + 4
Range("A1:N1").Interior.ColorIndex = 34
For brn = 1 To s2.[A65536].End(3).Row
    If Cells(brn, 1) <> "" Then Range("A" & brn & ":N" & brn).Borders.LineStyle = xlContinuous
    If Cells(brn, 1) = "S.NO." Then Range("A" & brn & ":N" & brn).Interior.ColorIndex = 34
Next
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem, " & Format(Timer - zaman, "0.00") & " saniye sürdü."
End Sub[/FONT]

 

[ASLAN7410]

Sayın Ömer Bey çok teşekkür ederim, emeğinize sağlık, gerçekten beni büyük bir yükten kurtardınız.

Sizden Allah razı olsun, hayırlı geceler diliyorum.

 

[Ömer BARAN]

Sayın Ömer Bey çok teşekkür ederim, emeğinize sağlık, gerçekten beni büyük bir yükten kurtardınız.

Sizden Allah razı olsun, hayırlı geceler diliyorum.

Eyvallah, iyi çalışmalar dilerim.

(Kuru teşekkür olur mu? Bir demli çay borcunuzu hesabınıza kaydettim! -- şaka elbette-- )
.

 

[ASLAN7410]

Sayın Ömer Bey çay hiç önemli değil, gerçekten istediğinizi ısmarlarım.

 

[ASLAN7410]

Sayın Ömer Bey sizin yazmış olduğunuz kodların arasına eklemeye çalıştım ancak yapamadım, yine yardımınıza ihtiyacım var.

Göndermiş olduğum excel sayfasındaki Sayfa1'deki A39 satırındaki başlığı Sayfa2'ye attığı verilerin her birinin baş tarafına yapıştırabilir mi?

 

[Ömer BARAN]

Yani aralardaki boşluk 3 satıra mı inecek, yoksa başlık+4 satırlık boşluk mu olacak.

 

[ASLAN7410]

Sayın Ömer Bey her 3 boşluktan sonra başlık ve veriler olacak.

 

[Ömer BARAN]

Önceki cevabımda yer alan kod'a ilave yaptım (mavi satır).
Sayfayı yenileyerek kontrol edin.

Kod'da kırmızı renklendirdiğim +4 kısmı aradaki boş satır sayısıdır,
duruma göre değiştirirsiniz.

Bu arada başlık satırlarının kaynağı Sayfa2'deki 1'inci satırdır, orada yapacağınız değişiklik alttakilere de yansır.
.

 

[ASLAN7410]

Sayın Ömer Bey çok teşekkür ederim, Allah razı olsun, çok işime yaradı, hayırlı geceler.

 

[Ömer BARAN]

Estağfurullah, iyi günler dilerim.

 

[Ömer BARAN]

Merhaba.

Yeni belgeniz ekte.

İyi bayramlar.

2 numaralı cevaptaki kodla, konu sahibinin sorunu çözüldüğünden bu cevap ekindeki belgeyi sildim.
.

 

[ASLAN7410]

Sayın Ömer Bey ilginiz için çok teşekkür ediyorum, emeğinize sağlık, kendi orijinal sayfamda uyarlayıp konudan bilgi vereceğim.

Hayırlı bayramlar.

 

[Ömer BARAN]

Bilmukabele, sağlıcakla.

 

[ASLAN7410]

Sayın Ömer Bey tekrar merhaba.

Göndermiş olduğunuz 12 mesajdaki kodları aynen kendi sayfam olan 22.000 satırlık sayfama ilave ettiğimde,
aktardığı sayfanın son kısmındaki tahminen 2000 satırlık veriyi sıralama yapıyor ancak alt kısımlarına cümle yazmıyor.

 

[Ömer BARAN]

Tekrar merhaba.

Bir hesap hatası yapmışım. 2 numaralı cevaptaki kod'u güncelledim.

2 numaralı cevabıma tekrar bakın isterseniz.
.

 

[ASLAN7410]

Merhaba hayırlı geceler Ömer Bey, kodu kendi ana sayfamda uygulayıp bilgi vereceğim.

 

[ASLAN7410]

Sayın Ömer Bey kodlar tam istediğim gibi çalışıyor, çok teşekkür ediyorum, Allah razı olsun hayırlı çalışmalar.

 

[Ömer BARAN]

Sayın Ömer Bey kodlar tam istediğim gibi çalışıyor, çok teşekkür ediyorum, Allah razı olsun hayırlı çalışmalar.

İyi günler dilerim.