Satır ve sütundaki sayıları rastgele karıştırma

[Muhammet Okumuş]

Satır ve sütun boyutlarını ayarlamak gerekiyor. Az sonra düzenleleyeyim. 5 dk mola versek olur değil mi?

 

[sinansinan]

tabiki çok yordum sizi

 

[Muhammet Okumuş]

Sn Sinan Bey,
Kod bölümünde yer alan
Range("A1:J21").ColumnWidth = 10 ---- sütun genişliği demektir.
Range("A1:J21").RowHeight = 40 ---- satır yüksekliği demektir.

10 ve 40 değerlerini sayfanıza sığacak şekilde değiştiriniz

 

[Muhammet Okumuş]

Yormaktan ziyade 5dk'lık işim vardı ondan istedim molayı.

 

[sinansinan]

sanki bu sığmama kenar boşluklarından kaynaklanıyor gibi ama. hücreleri çok daraltmak istemiyorum. Sayfa yapısı kısmından kenar boşluklarını 0 yapıyorum elle. o zaman tam bir sayfaya sığıyor. Hücreleri daraltırsam yazılanların okunması zor olacak. Çoğuna iki kelime yazılacak hücrelerin.

 

[Muhammet Okumuş]

Hocam onu artık sizin ayarlamanız gerekiyor.

 

[sinansinan]

Teşekkürler. Emeğinize sağlık.

 

[sinansinan]

Tekrar merhaba. Bir makro kaydederek çözdüm. Bir sayfada makro kaydederek düzenleme yaptım. Orada atadığım kısa yol tuşu ile de diğer sayfalarda tek tuşla aynı düzenlemeyi yaptım. En azından bu şekilde kısa yoldan çözülmüş oldu.

 

[Muhammet Okumuş]

O makroyu koda bağlayabilirseniz sonradan düzenleme yapmanıza gerek kalmaz.

 

[sinansinan]

Valla o konuda çok bilgim yok ama bir araştırayım bakalım koda nasıl bağlanıyormuş. Görüşmek üzere...

 

[sinansinan]

Makroyu kodun içine kaydedebildim sanırım. Dosyayı ekliyorum.

 

[Muhammet Okumuş]

Yazdığım kodun en altına Call yazıp yazmış olduğunuz kodun adını yanına yazınız.

 

[BedriA]

Merhaba,
Bu kodu kullanmak daha kullanışlı olur. Ancak kodun düzgün çalışabilmesi için verileriniz A1 hücresinden başlamalı ve sütunlardaki veriler aynı satırda son bulmalı. Yani A sütununda 10 satır dolu ise diğer sütunlarda da 10 satırın dolu olması lazım.

Hocam,

A1:A50 arasındaki dolu satırları sayıp, dolu olan satırları kendi arasında rastgele yer değiştirmesi mümkün mü?

Örneğin dolu 10 satır varsa bu 10 satırı kendi arasında yer değiştirsin istiyorum.

Yardımcı olabilir misiniz?

 

[halit3]

Hocam,

A1:A50 arasındaki dolu satırları sayıp, dolu olan satırları kendi arasında rastgele yer değiştirmesi mümkün mü?

Örneğin dolu 10 satır varsa bu 10 satırı kendi arasında yer değiştirsin istiyorum.

Yardımcı olabilir misiniz?

kod:

Private Sub sirala ()


Dim i As Long, sayi As Long, say As Long, sut As Long, son As Long, t As Long, j As Long
sayfa = ActiveSheet.Name
sut = 1
sayi = Worksheets(sayfa).Cells(Rows.Count, sut).End(3).Row

son = sayi
If sayi > son Then sayi = son

ReDim deg1(son)
ReDim deg2(son)


For j = 1 To sayi
If Worksheets(sayfa).Cells(j, sut).Value <> "" Then
deg1(j) = 0
Else
deg1(j) = 1
End If
Next j


For i = 1 To sayi

atla:
say = Int((Rnd * son) + 1)
If Worksheets(sayfa).Cells(i, sut).Value <> "" Then
If Val(deg1(say)) = 0 Then
deg2(i) = Worksheets(sayfa).Cells(say, sut).Value
deg1(say) = 1
Else
GoTo atla
End If
End If
Next i

For t = 1 To sayi
If Worksheets(sayfa).Cells(t, sut).Value <> "" Then
Sheets(sayfa).Cells(t, sut).Value = deg2(t)
End If
Next t


End Sub

 

[BedriA]

Çok teşekkür ederim Halit Hocam.

 

[ahmedummu]

Merhaba arkadaşlar. A1:B(En Son Dolu Satıra kadar karıştırabilir miyiz.)

A1'den başlayıp en son dolu satıra kadar karıştıracak ama bu arada B sütunuda karışacak. A sütununda bulunan bazı isimlerin karşısında (B sütununda) veriler var onlarda o isimlerle birlikte gidecek.

 

[halit3]

Merhaba arkadaşlar. A1:B(En Son Dolu Satıra kadar karıştırabilir miyiz.)

A1'den başlayıp en son dolu satıra kadar karıştıracak ama bu arada B sütunuda karışacak. A sütununda bulunan bazı isimlerin karşısında (B sütununda) veriler var onlarda o isimlerle birlikte gidecek.

kod:

Private Sub sirala2()


Dim i As Long, sayi As Long, say As Long, sut As Long, son As Long, t As Long, j As Long
sayfa = ActiveSheet.Name
sut = 1
sayi = Worksheets(sayfa).Cells(Rows.Count, sut).End(3).Row

son = sayi
If sayi > son Then sayi = son

ReDim deg1(son)
ReDim deg2(son)
ReDim deg3(son)

For j = 1 To sayi
If Worksheets(sayfa).Cells(j, sut).Value <> "" Then
deg1(j) = 0
Else
deg1(j) = 1
End If
Next j


For i = 1 To sayi
If Worksheets(sayfa).Cells(i, sut).Value <> "" Then
atla:
say = Int((Rnd * son) + 1)

If Val(deg1(say)) = 0 Then
deg2(i) = Worksheets(sayfa).Cells(say, sut).Value
deg3(i) = Worksheets(sayfa).Cells(say, sut + 1).Value
deg1(say) = 1
Else
GoTo atla
End If
End If
Next i

For t = 1 To sayi
If Worksheets(sayfa).Cells(t, sut).Value <> "" Then
Sheets(sayfa).Cells(t, sut).Value = deg2(t)
Sheets(sayfa).Cells(t, sut + 1).Value = deg3(t)
End If
Next t


End Sub

 

[ahmedummu]

Halit bey hayırlı geceler. Ellerinize sağlık.

 

[Asri]

Merhaba arkadaşlar. A1:B(En Son Dolu Satıra kadar karıştırabilir miyiz.)

A1'den başlayıp en son dolu satıra kadar karıştıracak ama bu arada B sütunuda karışacak. A sütununda bulunan bazı isimlerin karşısında (B sütununda) veriler var onlarda o isimlerle birlikte gidecek.

Alternatif;

C kolonunu yardımcı olarak kullanıp temizler.

Sub karistir()
   Application.ScreenUpdating = False
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   ustsayi = sonsatir: altsayi = 1
   Range("C1:C" & sonsatir).Clear
   For i = 2 To sonsatir
basla:
     DoEvents: Randomize
     sayi = Int((ustsayi - altsayi + 1) * Rnd + altsayi)
     If WorksheetFunction.CountIf(Range("C1:C" & sonsatir), sayi) > 0 Then GoTo basla
     If sayi = altsayi Then altsayi = sayi + 1
     If sayi = ustsayi Then ustsayi = sayi - 1
     Cells(i, "C").Value = sayi
   Next i
   Range("A:C").Sort Key1:=Cells(1, "C"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
   Columns("C:C").ClearContents
   Range("B1").Select
   Application.ScreenUpdating = True
   MsgBox ("Karıştırma işlemi tamamlandı.")
End Sub

 

[BedriA]

Halit Hocam,

Aşağıdaki kodu A2 den başlayacak şekilde nasıl değiştirebiliriz.
A1 satırında başlık var, o satırı da değiştiriyor.

Sub sorucevapdegistir()

Dim i As Long, sayi As Long, say As Long, sut As Long, son As Long, t As Long, j As Long
Sayfa = "sepet"
sut = 1
sayi = Worksheets(Sayfa).Cells(Rows.Count, sut).End(3).Row

son = sayi
If sayi > son Then sayi = son

ReDim deg1(son)
ReDim deg2(son)
ReDim deg3(son)

For j = 1 To sayi
If Worksheets(Sayfa).Cells(j, sut).Value <> "" Then
deg1(j) = 0
Else
deg1(j) = 1
End If
Next j


For i = 1 To sayi
If Worksheets(Sayfa).Cells(i, sut).Value <> "" Then
atla:
say = Int((Rnd * son) + 1)

If Val(deg1(say)) = 0 Then
deg2(i) = Worksheets(Sayfa).Cells(say, sut).Value
deg3(i) = Worksheets(Sayfa).Cells(say, sut + 1).Value
deg1(say) = 1
Else
GoTo atla
End If
End If
Next i

For t = 1 To sayi
If Worksheets(Sayfa).Cells(t, sut).Value <> "" Then
Sheets(Sayfa).Cells(t, sut).Value = deg2(t)
Sheets(Sayfa).Cells(t, sut + 1).Value = deg3(t)
End If
Next t

End Sub