• DİKKAT

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

Sadece satırda karıştırma...

R

rafetgulmez

Katılım
21 Mart 2009
Mesajlar
60
Excel Vers. ve Dili
2007 türkçe
Sütunlar sabit kalacak şekilde satırda karıştırma... Ekli dosyada daha fazla açıklama var... İlginiz için teşekkür ederim...


KARIŞTIRMA İLE İLGİLİ FORUMDA AŞAĞIDAKİ LİNKLERİ BULDUM FAKAT İŞİMİ GÖRMEDİ...

http://www.excel.web.tr/f14/satyrlary-yer-deoi-tir-t93284.html
http://www.excel.web.tr/f48/kary-tyr-ve-syrala-t81024.html
http://www.excel.web.tr/f50/kary-tyr-butonu-t75546.html
http://www.excel.web.tr/f48/random-hucre-secme-t58576.html
http://www.excel.web.tr/f48/kary-tyr-mix-i-lemi-yapmak-t74084.html
http://www.excel.web.tr/f14/vba-da-if-yapyly-komut-hata-veriyor-t61945.html
http://www.excel.web.tr/f48/sayylary-kary-tyr-ve-daoyt-t59901.html
http://www.excel.web.tr/f48/1-52-arasy-sayylary-kary-tyrmak-t49524.html
http://www.excel.web.tr/f48/excel-de-once-kura-sonra-fikstur-t94337.html
 

Ekli dosyalar

Son düzenleme:
Merhaba,

Bu şekilde deneyiniz..

Kod: 
Sub SaySil()
 
Dim son As Long, i As Long
son = Cells(Rows.Count, "D").End(xlUp).Row
 
For i = son To 3 Step -1
    If WorksheetFunction.CountIf(Range("D" & i & ":M" & i), _
        Range("D" & i)) = 10 Then
        Rows(i).Delete
    End If
Next i
 
End Sub
.
 
Olmadı...

Ömer' Alıntı:
Merhaba,

Bu şekilde deneyiniz..

Kod: 
Sub SaySil()
 
Dim son As Long, i As Long
son = Cells(Rows.Count, "D").End(xlUp).Row
 
For i = son To 3 Step -1
    If WorksheetFunction.CountIf(Range("D" & i & ":M" & i), _
        Range("D" & i)) = 10 Then
        Rows(i).Delete
    End If
Next i
 
End Sub
.
Genişletmek için tıkla ...

Hocam ilgilendiğin için teşekkür ederim ama verdiğin formül satır siliyor... Aradığım çözüm değil.

İstenen şey "çok net" Satırdaki sayılar karışacak ve "benzersiz sütunlar" elde edilecek..
 
Yardımcı olacak kimse yok mu arkadaşlar? Kod bilen birisi için çok zor bi konu olduğunu düşünmüyorum açıçası.............
 
Selamlar,

Aşağıdaki kodu denermisiniz.

Kod: 
Option Explicit
 
Sub DEĞERLERİ_KARIŞTIR()
    Dim X1 As Byte, X2 As Integer, X3 As Byte, X4 As Byte
    Dim SON_SATIR As Integer, SAYI As Integer, SATIR As Integer
    Dim SAY1 As Long, SAY2 As Long, SAY3 As Long
    Dim ADRES1 As String, ADRES2 As String
    
    SON_SATIR = Range("D65536").End(3).Row
    SATIR = 1
    SAY1 = SON_SATIR - 2
    
BAŞLA1:
    Range("IU:IV").ClearContents
    
    For X1 = 4 To Range("IV2").End(1).Column
        For X2 = 1 To SAY1
BAŞLA2:
            Randomize
            SAYI = Int(Rnd() * SON_SATIR + 1)
            If WorksheetFunction.CountIf(Range("IU:IU"), SAYI) = 0 Then
                If SAYI > 2 Then
                    Cells(SATIR, 255) = SAYI
                    Cells(SATIR, 256) = Cells(SAYI, X1)
                    SATIR = SATIR + 1
                Else
                    GoTo BAŞLA2
                End If
            Else
                GoTo BAŞLA2
            End If
        Next
        
        Range(Cells(3, X1), Cells(SON_SATIR, X1)).Value = Range("IV1:IV" & Range("IV65536").End(3).Row).Value
        Range("IU:IV").ClearContents
        SATIR = 1
    Next
    Range("IU:IV").ClearContents
    For X3 = 4 To Range("IV2").End(1).Column
        ADRES1 = Range(Cells(3, X3), Cells(SON_SATIR, X3)).Address
        SAY2 = WorksheetFunction.CountA(Range(ADRES1))
        For X4 = 4 To Range("IV2").End(1).Column
            If X3 <> X4 Then
                ADRES2 = Range(Cells(3, X4), Cells(SON_SATIR, X4)).Address
                SAY3 = Evaluate("=SUMPRODUCT(--(" & ADRES1 & "=" & ADRES2 & "))")
                If SAY2 = SAY3 Then GoTo BAŞLA1
            End If
        Next
    Next
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 

Ekli dosyalar

Maalesef

Korhan Ayhan' Alıntı:
Selamlar,

Aşağıdaki kodu denermisiniz.

Kod: 
Option Explicit
 
Sub DEĞERLERİ_KARIŞTIR()
    Dim X1 As Byte, X2 As Integer, X3 As Byte, X4 As Byte
    Dim SON_SATIR As Integer, SAYI As Integer, SATIR As Integer
    Dim SAY1 As Long, SAY2 As Long, SAY3 As Long
    Dim ADRES1 As String, ADRES2 As String
    
    SON_SATIR = Range("D65536").End(3).Row
    SATIR = 1
    SAY1 = SON_SATIR - 2
    
BAŞLA1:
    Range("IU:IV").ClearContents
    
    For X1 = 4 To Range("IV2").End(1).Column
        For X2 = 1 To SAY1
BAŞLA2:
            Randomize
            SAYI = Int(Rnd() * SON_SATIR + 1)
            If WorksheetFunction.CountIf(Range("IU:IU"), SAYI) = 0 Then
                If SAYI > 2 Then
                    Cells(SATIR, 255) = SAYI
                    Cells(SATIR, 256) = Cells(SAYI, X1)
                    SATIR = SATIR + 1
                Else
                    GoTo BAŞLA2
                End If
            Else
                GoTo BAŞLA2
            End If
        Next
        
        Range(Cells(3, X1), Cells(SON_SATIR, X1)).Value = Range("IV1:IV" & Range("IV65536").End(3).Row).Value
        Range("IU:IV").ClearContents
        SATIR = 1
    Next
    Range("IU:IV").ClearContents
    For X3 = 4 To Range("IV2").End(1).Column
        ADRES1 = Range(Cells(3, X3), Cells(SON_SATIR, X3)).Address
        SAY2 = WorksheetFunction.CountA(Range(ADRES1))
        For X4 = 4 To Range("IV2").End(1).Column
            If X3 <> X4 Then
                ADRES2 = Range(Cells(3, X4), Cells(SON_SATIR, X4)).Address
                SAY3 = Evaluate("=SUMPRODUCT(--(" & ADRES1 & "=" & ADRES2 & "))")
                If SAY2 = SAY3 Then GoTo BAŞLA1
            End If
        Next
    Next
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...

Hocam ilginiz için tşk ederim fakat verdiğiniz örnekte hem yatayda hem dikeyde karıştırma yapıyor sadece yatayda olması gerekiyor....
 
Selamlar,

Aşağıdaki kodu denermisiniz.

Kod: 
Option Explicit
 
Sub YATAYDA_DEĞERLERİ_KARIŞTIR()
    Dim X1 As Byte, X2 As Integer, X3 As Byte, X4 As Byte
    Dim SON_SATIR As Integer, SON_SÜTUN As Byte
    Dim SAYI As Integer, SÜTUN As Integer
    Dim SAY1 As Long, SAY2 As Long
    Dim ADRES1 As String, ADRES2 As String
    
    SON_SATIR = Range("D65536").End(3).Row
    SON_SÜTUN = Range("IV2").End(1).Column
    SÜTUN = 1
    
BAŞLA1:
    Sheets("Sayfa2").Rows("1:2").ClearContents
    
    For X1 = 3 To SON_SATIR
        For X2 = 4 To SON_SÜTUN
BAŞLA2:
            Randomize
            SAYI = Int(Rnd() * SON_SÜTUN + 1)
            If WorksheetFunction.CountIf(Sheets("Sayfa2").Rows(1), SAYI) = 0 Then
                If SAYI > 3 Then
                    Sheets("Sayfa2").Cells(1, SÜTUN) = SAYI
                    Sheets("Sayfa2").Cells(2, SÜTUN) = Sheets("Sayfa1").Cells(X1, SAYI)
                    SÜTUN = SÜTUN + 1
                Else
                    GoTo BAŞLA2
                End If
            Else
                GoTo BAŞLA2
            End If
        Next
        
        Range(Cells(X1, 4), Cells(X1, SON_SÜTUN)).Value = Sheets("Sayfa2").Range("A2:" & Cells(2, SON_SÜTUN - 3).Address).Value
        Sheets("Sayfa2").Rows("1:2").ClearContents
        SÜTUN = 1
    Next
    Sheets("Sayfa2").Rows("1:2").ClearContents
    For X3 = 4 To SON_SÜTUN
        ADRES1 = Range(Cells(3, X3), Cells(SON_SATIR, X3)).Address
        SAY1 = WorksheetFunction.CountA(Range(ADRES1))
        For X4 = 4 To SON_SÜTUN
            If X3 <> X4 Then
                ADRES2 = Range(Cells(3, X4), Cells(SON_SATIR, X4)).Address
                SAY2 = Evaluate("=SUMPRODUCT(--(" & ADRES1 & "=" & ADRES2 & "))")
                If SAY1 = SAY2 Then GoTo BAŞLA1
            End If
        Next
    Next
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
ÇÖZÜLDÜ!

korhan ayhan' Alıntı:
selamlar,

aşağıdaki kodu denermisiniz.

Kod: 
option explicit
 
sub yatayda_değerleri_karıştır()
    dim x1 as byte, x2 as ınteger, x3 as byte, x4 as byte
    dim son_satır as ınteger, son_sütun as byte
    dim sayı as ınteger, sütun as ınteger
    dim say1 as long, say2 as long
    dim adres1 as string, adres2 as string
    
    son_satır = range("d65536").end(3).row
    son_sütun = range("ıv2").end(1).column
    sütun = 1
    
başla1:
    Sheets("sayfa2").rows("1:2").clearcontents
    
    for x1 = 3 to son_satır
        for x2 = 4 to son_sütun
başla2:
            Randomize
            sayı = ınt(rnd() * son_sütun + 1)
            ıf worksheetfunction.countıf(sheets("sayfa2").rows(1), sayı) = 0 then
                ıf sayı > 3 then
                    sheets("sayfa2").cells(1, sütun) = sayı
                    sheets("sayfa2").cells(2, sütun) = sheets("sayfa1").cells(x1, sayı)
                    sütun = sütun + 1
                else
                    goto başla2
                end ıf
            else
                goto başla2
            end ıf
        next
        
        range(cells(x1, 4), cells(x1, son_sütun)).value = sheets("sayfa2").range("a2:" & cells(2, son_sütun - 3).address).value
        sheets("sayfa2").rows("1:2").clearcontents
        sütun = 1
    next
    sheets("sayfa2").rows("1:2").clearcontents
    for x3 = 4 to son_sütun
        adres1 = range(cells(3, x3), cells(son_satır, x3)).address
        say1 = worksheetfunction.counta(range(adres1))
        for x4 = 4 to son_sütun
            ıf x3 <> x4 then
                adres2 = range(cells(3, x4), cells(son_satır, x4)).address
                say2 = evaluate("=sumproduct(--(" & adres1 & "=" & adres2 & "))")
                ıf say1 = say2 then goto başla1
            end ıf
        next
    next
 
    msgbox "işleminiz tamamlanmıştır.", vbınformation
end sub
Genişletmek için tıkla ...

eyvallah hocam çok çok teşekkür ettim gecenin bu vaktinde ilgilendiğin için... Eline zihnine sağlık....
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst