sütun bölmek

[gehlen]

elimde a sütununda veriler olan excel dosyaları var.( satır sayısı değişken). a sütunundaki verileri (satır sayısı kaç olursa olsun) 3 'e bölerek a-c-e sütunları arasında eşit olarak paylaştırmasını istiyorum.(maksat kağıt israfını önlemek)

Teşekkürler şimdiden...

 

[Necdet]

Merhaba,

Sub SutunaBol()
Dim i       As Long
Dim j       As Integer
Dim Bolum   As Integer
Dim Adet    As Integer
Adet = Application.InputBox("Kaç Sütuna Bölünecek?", "Değişken Alma", 3, Type:=1)
If Adet = 0 Then Exit Sub
Bolum = Int([A65536].End(3).Row / Adet)
Application.ScreenUpdating = False
For j = 1 To Adet
    If j = 1 Then
        i = 2
    Else
        i = (j - 1) * Bolum + 2
    End If
    
    Range("A" & i & ":A" & i + Bolum - 1).Cut
    Cells(2, j + 1).Select
    ActiveSheet.Paste
Next j
Columns("A:A").Delete
Application.ScreenUpdating = True
End Sub

 

[gehlen]

Öncelikle teşekkür ederim ancak yukarıdaki makroda:

1.66532 satırdan fazlasını desteklemiyor,

2. A
1
2
3
4
şeklinde bir sütunu 3 sütuna bölmek istediğimde
A B C
2 3 4

şeklinde bölüp A1 hücresinde bulunan "1" sayısını yok ediyor. ACİL Yardımlarını bekliyorum.

 

[gehlen]

Acil yardımlarınızı bekliyorum

 

[gehlen]

Acil yardımlarınızı bekliyorum

 

[Necdet]

Merhaba,

Örnek dosyada eklediğim gibi;
1. Birinci satırda başlık olur diye düşünmüştüm
2. Dosyayı xl 2003 sürümüne göre düşündüğümden [A65536] son hücre değerini kullandığımdan fazlasını görmedi.

Sub SutunaBol()
Dim i       As Long
Dim j       As Integer
Dim Bolum   As Integer
Dim Adet    As Integer
Adet = Application.InputBox("Kaç Sütuna Bölünecek?", "Değişken Alma", 3, Type:=1)
If Adet = 0 Then Exit Sub
Bolum = Int(Application.WorksheetFunction.RoundUp([B][COLOR=red][A1048576][/COLOR][/B].End(3).Row / Adet, 0))
Application.ScreenUpdating = False
For j = 1 To Adet
    If j = 1 Then
       [B][COLOR=red] i = 1
[/COLOR][/B]    Else
        i = (j - 1) * Bolum + 1
    End If
    
    Range("A" & i & ":A" & i + Bolum - 1).Cut
    Cells(1, j + 1).Select
    ActiveSheet.Paste
Next j
Columns("A:A").Delete
Application.ScreenUpdating = True
End Sub

 

[gehlen]

Şimdi süper oldu çok teşekkür ederim, ellerinize sağlık...

 

[Necdet]

Merhaba,

Satır adedini tama yakın hesaplar şekli ile :

Sub SutunaBol()
Dim i       As Long
Dim j       As Integer
Dim Bolum   As Integer
Dim Adet    As Integer
Adet = Application.InputBox("Kaç Sütuna Bölünecek?", "Değişken Alma", 3, Type:=1)
If Adet = 0 Then Exit Sub
Bolum = Int([A1048576].End(3).Row / Adet)
Application.ScreenUpdating = False
For j = 1 To Adet
    i = (j - 1) * Bolum + 1
    If j = Adet Then
        Range("A" & i & ":A" & i + Bolum).Cut
    Else
        Range("A" & i & ":A" & i + Bolum - 1).Cut
    End If
 
    Cells(1, j + 1).Select
    ActiveSheet.Paste
Next j
Columns("A:A").Delete
Application.ScreenUpdating = True
End Sub

 

[gehlen]

re

süper, ellerinize sağlık.
minik bir sorum daha olacak. mesela 3 değil de 4 e bölmek istersek de değişiklik yaparak aynı makroyu kullanabilir miyiz.
Şunun için sordum a sütununda 9 satır varken sorduğunda 3 yerine 4 yazınca sorun yok da A sütununda 85000 veri olunca "Debug i = (j - 1) * Bolum + 1" dedi ...

 

[gehlen]

evet son durum şu:
A sütununu 4 e bölmek istediğimde A sütununda 10-15 satır varsa sorun yok ancak 300-500 satır varsa "Run Time Error 424" veriyor.Debug yaptığımda ise "Bolum = Int([A1048576].End(3).Row / Adet)" gösteriyor.

Teşekkürler şimdiden...

 

[Korhan Ayhan]

Selamlar,

Kod içinde geçen tüm INTEGER ifadelerini LONG olarak değiştirip denermisiniz.

 

[gehlen]

Sağolun, Denedim bölme işini sorunsuz yaptı ama A sütununda yer alan 85022 adet hücreyi bölme işleminden sonra 85021 'e düşürdü. (Kaybolan sayıyı tespit edemedim.) Tavsiyenizi ilk formüle uyarlayınca sorunsuz yaptı. EMEĞİ GEÇEN TÜM ARKADAŞLARA TEŞEKKÜR EDERİM. SON VE ÇALIŞIR HALİ ŞU ŞEKİLDEDİR.

Sub SutunaBol()
Dim i As Long
Dim j As Long
Dim Bolum As Long
Dim Adet As Long
Adet = Application.InputBox("Kaç Sütuna Bölünecek?", "Değişken Alma", 3, Type:=1)
If Adet = 0 Then Exit Sub
Bolum = Int(Application.WorksheetFunction.RoundUp([A1048576].End(3).Row / Adet, 0))
Application.ScreenUpdating = False
For j = 1 To Adet
If j = 1 Then
i = 1
Else
i = (j - 1) * Bolum + 1
End If

Range("A" & i & ":A" & i + Bolum - 1).Cut
Cells(1, j + 1).Select
ActiveSheet.Paste
Next j
Columns("A:A").Delete
Application.ScreenUpdating = True
End Sub

 

[Necdet]

Merhaba,

Hâlâ 2007 nin sınırlarını düşünemiyorum 32000 den büyük rakam olunca integer tanımla değerler doğal olarak yetmiyor.