• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

Satır ve sütun boyutlarını ayarlamak gerekiyor. Az sonra düzenleleyeyim. 5 dk mola versek olur değil mi?:)
 
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
 
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.
 
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.
 
O makroyu koda bağlayabilirseniz sonradan düzenleme yapmanıza gerek kalmaz.
 
Valla o konuda çok bilgim yok ama bir araştırayım bakalım koda nasıl bağlanıyormuş. Görüşmek üzere...
 
Yazdığım kodun en altına Call yazıp yazmış olduğunuz kodun adını yanına yazınız.
 
Muhammet Okumuş' Alıntı:
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.
Genişletmek için tıkla ...

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?
 
BedriA' Alıntı:
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?
Genişletmek için tıkla ...

kod:

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
 
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.
 
Moderatör tarafında düzenlendi:
ahmedummu' Alıntı:
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.
Genişletmek için tıkla ...

kod:

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' Alıntı:
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.
Genişletmek için tıkla ...

Alternatif;

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

Kod: 
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
 
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.

Kod: 
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst