Kod ile Kopyala-Taşı-Yapıştır yardım ?

[Gorarr]

Selamlar. Şöyle bir problemle karşı karşıyayım, aramalarım ve çabalarım malesef sonuç vermedi. Excel içerisinde belli bölgedeki dizilimleri boşluk kalmayacak şekilde dizmek istiyorum. Örnek dosyamda daha net açıkladım. Benim için birhayli önemli bir işlem. Yardımcı olabilirseniz çok servinirim.

 

[Gorarr]

Aceba sorum geridemi kaldı. Çözüm konusunda yardımlarınızı bekliyorum..

 

[leumruk]

Selamlar. Şöyle bir problemle karşı karşıyayım, aramalarım ve çabalarım malesef sonuç vermedi. Excel içerisinde belli bölgedeki dizilimleri boşluk kalmayacak şekilde dizmek istiyorum. Örnek dosyamda daha net açıkladım. Benim için birhayli önemli bir işlem. Yardımcı olabilirseniz çok servinirim.

Merhaba,
Dağınık ve çok miktarda aralık kullanacağınız düşüncesiyle esnek bir kod yazdım. Yapmanız gereken kırmızı ile belirttiğim kısma tüm aralıklarınızı sırasıyla yazmak.

Sub Sirala()
Dim sonuc As Variant
Application.ScreenUpdating = False
[COLOR="DarkRed"]deg = Array("c2:j2", "p2:w2", "c4:j4", "c13:j13", "c15:j15", "p13:w13")[/COLOR]
For arl = LBound(deg) To UBound(deg)
Set Aralik = Range(deg(arl))
Sat = Aralik.Row
ilksut = Aralik.Column
sonsut = Aralik.Column + Aralik.Count - 1
For x = sonsut To ilksut Step -1
If Cells(Sat, x) = "" Then
Set bolum = Range(Cells(Sat, x + 1), Cells(Sat, sonsut))
sonuc = bolum
Range(Cells(Sat, x), Cells(Sat, sonsut - 1)) = sonuc
Cells(Sat, sonsut) = ""
End If
Next
Next
MsgBox "İşlem tamam.", vbInformation, "leumruk"
End Sub

 

[Gorarr]

Ellerinize sağlık çok süper. Tam istediğim gibi. Çok çok teşekkür ederim. Saygılar selamlar.....