Soru Satırlardaki 500 kelimeyi 10'ar 10'ar çekme

[medyaisleri]

Merhabalar, foruma uzun süredir giriyor çıkıyor faydalanıyorum. Yeni kayıt olma fırsatı buldum. Bu platformda olan herkese teşekkür ediyorum.

Geçmiş konulardan baktığım kadarıyla bulamadım, siz hocalarıma sormak istiyorum.

Alt alta 500 kelimelik bir dosyam var. Hepsi A sütununda ve A1 A2 A3 diye sıralanmış vaziyette. Bunları 10'arlı 10'arlı B sütununa veya başka bir yere bölüp taşımak istiyorum. Gösterecek olursak şu;

A SÜTUNU
ahmet A1
mehmet A2
sami
yasin
çimen
yeşil
kırmızı
mavi
mor
siyah
beyaz

BU ŞEKİLDE 500'e kadar gidiyor.
yapılması gereken;

B1
ahmet mehmet sami yasin çimen yeşil kırmızı mavi mor siyah
B2
beyaz.....

şeklinde. şimdiden teşekkür ediyorum...

 

[Necdet]

Merhaba,

Açıklama yetersiz gibi geldi bana? A sütunu mu yoksa A1 hücresi mi?

 

[medyaisleri]

Merhaba,

Açıklama yetersiz gibi geldi bana? A sütunu mu yoksa A1 hücresi mi?

Çok özür dilerim A sütunu hocam. Hemen düzeltiyorum.

 

[çıtır]

Foruma hoş geldiniz.Bir modüle kopyalayarak deneyiniz.

Sub Birleştir()
Dim s1 As Worksheet
Set s1 = Sheets("Sayfa1")
Dim rng As Range, iSat As Integer
Dim brlyz As Variant
 satir = s1.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = s1.Range("A1:A" & satir)
s1.Range("B1:B" & Rows.Count).Cells.ClearContents
iSat = 1
sat = 1
Do
 For iSat = iSat To iSat + 9
If Not rng(iSat, 1).Value = vbNullString Then
brlyz = brlyz & "," & rng(iSat, 1).Value
End If
Next iSat
s1.Range("B" & sat) = Mid(brlyz, 2)
sat = sat + 1
brlyz = Empty
Loop While iSat < satir
MsgBox "işlem bitirildi", vbInformation
 End Sub

 

[medyaisleri]

Foruma hoş geldiniz.Bir modüle kopyalayarak deneyiniz.

Sub Birleştir()
Dim s1 As Worksheet
Set s1 = Sheets("Sayfa1")
Dim rng As Range, iSat As Integer
Dim brlyz As Variant
satir = s1.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = s1.Range("A1:A" & satir)
s1.Range("B1:B" & Rows.Count).Cells.ClearContents
iSat = 1
sat = 1
Do
For iSat = iSat To iSat + 9
If Not rng(iSat, 1).Value = vbNullString Then
brlyz = brlyz & "," & rng(iSat, 1).Value
End If
Next iSat
s1.Range("B" & sat) = Mid(brlyz, 2)
sat = sat + 1
brlyz = Empty
Loop While iSat < satir
MsgBox "işlem bitirildi", vbInformation
End Sub

Harikasınız ya. Çok teşekkür ediyorum değerli hocam.

 

[çıtır]

Harikasınız ya. Çok teşekkür ediyorum değerli hocam.

Rica ederim.Dönüş yaptığınız için teşekkür ederim.

 

[ÖmerBey]

Merhaba,
Alternatif olsun...

Sub kod()
Dim a As Integer, b As Byte, x As Integer
Dim met As String
Range("B:B").ClearContents
For a = 1 To Cells(Rows.Count, 1).End(3).Row Step 10
    met = Cells(a, 1)
    For b = 1 To 9
        met = met & " " & Cells(a + b, 1)
    Next
    x = x + 1
    Cells(x, 2) = met
Next
End Sub

 

[medyaisleri]

Merhaba,
Alternatif olsun...

Sub kod()
Dim a As Integer, b As Byte, x As Integer
Dim met As String
Range("B:B").ClearContents
For a = 1 To Cells(Rows.Count, 1).End(3).Row Step 10
    met = Cells(a, 1)
    For b = 1 To 9
        met = met & " " & Cells(a + b, 1)
    Next
    x = x + 1
    Cells(x, 2) = met
Next
End Sub

teşekkürler