• DİKKAT

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

permütasyon

pardon meslan zaten kodların içinde varmış
tekrar çok teşekkür ederim ellerine sağlık
 
Sayın meslan;
sizden son birşey daha isteyebilir miyim?
Yapmak istediğim şeyi ekte anlattım eğer onuda yapabilirseniz program tam istediğim gibi olacak.
Yapamazsanızda canınız sağolsun.
 

Ekli dosyalar

Merhaba,

Hız mükemmel...
Kod: 
Sub test3()
Dim a As Byte, b As Byte, c As Byte
Dim d As Byte, e As Byte, f As Byte
Dim s As Long, arr(1 To 65536, 1 To 6) As Integer
Dim m As Byte

m = 8

Columns("h:iv").ClearContents

    For a = 1 To [a1]
        For b = 1 To [b1]
            For c = 1 To [c1]
                For d = 1 To [d1]
                    For e = 1 To [e1]
                        For f = 1 To [f1]
                            s = s + 1
                            arr(s, 1) = a
                            arr(s, 2) = b
                            arr(s, 3) = c
                            arr(s, 4) = d
                            arr(s, 5) = e
                            arr(s, 6) = f
                            If s = 65536 Then
                                Range(Cells(1, m), Cells(65536, m + 5)) = arr
                                s = 0
                                m = m + 7
                                Erase arr
                            End If
                        Next
                    Next
                Next
            Next
        Next
    Next
    
    Erase arr
End Sub
 
Merhaba
Kod: 
Sub carp()
Dim x, y, z As Long
For x = 4 To [A65536].End(3).Row
    z = 1
        For y = 1 To Rows(x).End(2).Column
            Set bul = Sheets("Sayfa2").Columns(z).Find(Cells(x, y).Value, lookat:=xlWhole)
            If Not bul Is Nothing Then
                Cells(x, y).Value = bul.Next * Cells(x, y).Value
                z = z + 2
        End If
    Next
Next
End Sub
 
Zeki Gürsoy' Alıntı:
Merhaba,

Hız mükemmel...
Kod: 
Sub test3()
Dim a As Byte, b As Byte, c As Byte
Dim d As Byte, e As Byte, f As Byte
Dim s As Long, arr(1 To 65536, 1 To 6) As Integer
Dim m As Byte

m = 8

Columns("h:iv").ClearContents

    For a = 1 To [a1]
        For b = 1 To [b1]
            For c = 1 To [c1]
                For d = 1 To [d1]
                    For e = 1 To [e1]
                        For f = 1 To [f1]
                            s = s + 1
                            arr(s, 1) = a
                            arr(s, 2) = b
                            arr(s, 3) = c
                            arr(s, 4) = d
                            arr(s, 5) = e
                            arr(s, 6) = f
                            If s = 65536 Then
                                Range(Cells(1, m), Cells(65536, m + 5)) = arr
                                s = 0
                                m = m + 7
                                Erase arr
                            End If
                        Next
                    Next
                Next
            Next
        Next
    Next
    
    Erase arr
End Sub
Genişletmek için tıkla ...

sayın zeki bey kodu yazdım yalnız TYPE MİSMATCH diye ir hata veriyoe neden olabilir acaba.
 
meslan' Alıntı:
Merhaba
Kod: 
Sub carp()
Dim x, y, z As Long
For x = 4 To [A65536].End(3).Row
    z = 1
        For y = 1 To Rows(x).End(2).Column
            Set bul = Sheets("Sayfa2").Columns(z).Find(Cells(x, y).Value, lookat:=xlWhole)
            If Not bul Is Nothing Then
                Cells(x, y).Value = bul.Next * Cells(x, y).Value
                z = z + 2
        End If
    Next
Next
End Sub
Genişletmek için tıkla ...
sayın meslan bu makroyu diğer makroyla birleştirmemiz mümkün mü?Bir de bu makroyu çalıştırmaya çalıştım sayfa 2 deki olmayan bi değeri atadı onuda anlayamadım.
 
Mümkün
Sub carp() ile End Sub arasını kopyala.
End Sub dan önce yapıştır.
Bu kadar.
 
sayın meslan denedim ama beceremedim rica etsem siz yapabilir misiniz?
 
İnşallah bunu kopyaladım ya nereye yapıştıracağım demezsin.
Kod: 
Sub test2()
[A4:IV65536] = Empty
Dim a As Byte, b As Byte, c As Byte
Dim d As Byte, e As Byte, f As Byte
Dim s As Long
Dim x As Long
x = 1
s = 4
    For a = 1 To [a1]
        For b = 1 To [b1]
            For c = 1 To [c1]
                For d = 1 To [d1]
                    For e = 1 To [e1]
                        For f = 1 To [f1]
                            Cells(s, x) = a
                            Cells(s, x + 1) = b
                            Cells(s, x + 2) = c
                            Cells(s, x + 3) = d
                            Cells(s, x + 4) = e
                            Cells(s, x + 5) = f
                            s = s + 1
                            If s = 65536 Then x = x + 7: s = 4
                        Next
                    Next
                Next
            Next
        Next
    Next
    
 Dim x, y, z As Long
For x = 4 To [A65536].End(3).Row
    z = 1
        For y = 1 To Rows(x).End(2).Column
            Set bul = Sheets("Sayfa2").Columns(z).Find(Cells(x, y).Value, lookat:=xlWhole)
            If Not bul Is Nothing Then
                Cells(x, y).Value = bul.Next * Cells(x, y).Value
                z = z + 2
        End If
    Next
Next

End Sub
 
sayın mesalan dediğinizi yaptım yalnız makroyu çalıştırınca hata verdi
compile error
Duplicate declaration in current scope
hakkınızı da helal edin çok uğraştırdım sizi de.
 
hata şundan kaynaklandı herhalde bi yukarıda x tanımlı birde aşağıda başka bir x tanımlı çakışıyo olabilirler mi. Ben aşağıdaki x i başka bir harf yaptım çalıştı makro fakat bu sefer de sayfa 2 de olmayan değerleri getiriyo sayfa 2 de 0,24 diye birşey 0,24 gibi 0,80 gibi değerleri getiriyo.
Benim için çok önemli eğer yapabilirseniz çok mutlu olacam.
 
sayın meslan ilk önce sizi bu kadar uğraştırdığım için hakkınızı helal edin.
Ama sorun F5 hücresindeki değer 0,24 sayfa 2 de yok 0,24 yerine 0,12 olması lazım F11 hücresi keza öyle E10 hücresinde 0,28 yazıyo normalde 0,14 olması lazım 2 katını yazmış hep.
 
sayın meslan sizin yazdığınız kod şunu yapıyo herhalde
1 1 1 1 1 1 ilk ifademiz bu ya bunu sayfa 2 de buluyo 1 ile 1 in karşısındaki sayıyı çarpıyo
benim istediğim ise 1 in karşısındaki ifadeyi alacak diğer 1 in karşısındaki ifadeyle çarpacak yani sadece ondalık sayıları çarpacak.
 
iskelet' Alıntı:
sayın meslan sizin yazdığınız kod şunu yapıyo herhalde
1 1 1 1 1 1 ilk ifademiz bu ya bunu sayfa 2 de buluyo 1 ile 1 in karşısındaki sayıyı çarpıyo
benim istediğim ise 1 in karşısındaki ifadeyi alacak diğer 1 in karşısındaki ifadeyle çarpacak yani sadece ondalık sayıları çarpacak.
Genişletmek için tıkla ...

Şunu
Kod: 
Cells(i, y).Value = bul.Next * Cells(i, y).Value

Bununla
Kod: 
Cells(i, y).Value = bul.Next * bul.Next.Next.Next
değiştirip deneyin.
 
sayın meslan
teşekkür ederim ama olmadı . Herhalde ben tam anlatamadım ne yapmak istediğimi.
Ekteki dosyada anlattım bi bakabilirseniz çok sevinirim.
 

Ekli dosyalar

iskelet' Alıntı:
sayın meslan
teşekkür ederim ama olmadı . Herhalde ben tam anlatamadım ne yapmak istediğimi.
Ekteki dosyada anlattım bi bakabilirseniz çok sevinirim.
Genişletmek için tıkla ...

Bir de şunu dene
Kod: 
For i = 4 To [A65536].End(3).Row
    z = 1
     deg = 1
        For y = 1 To Cells(i, "Iv").End(1).Column
          Set bul = Sheets("Sayfa2").Columns(z).Find(Cells(i, y).Value, lookat:=xlWhole)
            If Not bul Is Nothing Then
                deg = deg * bul.Next
                Cells(i, 7) = deg
            Else
              Cells(i, y).Font.ColorIndex = 3
           End If
        z = z + 2
        If z = 13 Then z = 1
    Next
Next
 
meslan' Alıntı:
Bir de şunu dene
Kod: 
For i = 4 To [A65536].End(3).Row
    z = 1
     deg = 1
        For y = 1 To Cells(i, "Iv").End(1).Column
          Set bul = Sheets("Sayfa2").Columns(z).Find(Cells(i, y).Value, lookat:=xlWhole)
            If Not bul Is Nothing Then
                deg = deg * bul.Next
                Cells(i, 7) = deg
            Else
              Cells(i, y).Font.ColorIndex = 3
           End If
        z = z + 2
        If z = 13 Then z = 1
    Next
Next
Genişletmek için tıkla ...
Sayın meslan,
Çok teşekkür ederim. Oldu bu sefer ellerinize sağlık.
 
sayın meslan,
programda 7 7 7 7 7 7 yazdığımda satır yetmediği için yan tarafa geçtiği zaman yan taraftaki çarpmayı yapmıyo neden yapmıyo olabilir acaba?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst