Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > EXCEL-Soruları > Makro-VBA
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Makro-VBA Makro veya VBA ile ilgili sorularınızı buraya gönderebilirsiniz.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 10-08-2017, 23:47   #1
Muharrem41
 
Giriş: 15/09/2016
Şehir: kocaeli
Mesaj: 33
Excel Vers. ve Dili:
türkçe 2007
Varsayılan Kombinasyon makrosunu revize etmek

merhaba ARKADAŞLAR:VE BÜYÜKLERİM VE KÜÇÜKLERİM
sitede sayısal loto macro ları var bana buna benzer 4 adet macro lazım
örnek vermek gerekirse elimde 30 adet araç var bunların plakalarını girerek işlem yapmak istiyorum sitede bulunan sayısal loto macrosuna benzer rakamları ben kendim belirlemek istiyorum örnek olara 1,3,28,53,72,17,46,79,80 gibi düşünelim be bu macro ları 5 li 6 lı
8li 10 lu olarak yapmak istiyorum ama tüm sonuçları sayfada görmek istiyorum yardımlarınız için şimdiden teşekkür ederim ÖRNEK:MACRO PİLİNT TARAFINDAN BANA YOLLANDI BEN BUNU 1/49 OLARAK DEGİLDE YUKARIDA RAKAMLARI KENDİ YAZDIĞIM GİBİ BELİRLEMEK İSTİYORUM.BUNU YAPMA ŞANSIM VARMI BİLMİYORUM YARDIMLARINIZ İÇİN TEŞEKKÜRLER ŞİMDİDEN.

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Sub Listele()
Dim x As Byte, y As Long, z As Long
Dim a As Byte, b As Byte, c As Byte, d As Byte, e As Byte, f As Byte, g As Byte

Cells.Clear
x = 49
z = 1

For a = 1 To x
For b = a + 1 To x
For c = b + 1 To x
For d = c + 1 To x
For e = d + 1 To x
For f = e + 1 To x
y = y + 1
If y > 1048576 Then
y = 1
z = z + 7
End If
Cells(y, z) = a
Cells(y, z + 1) = b
Cells(y, z + 2) = c
Cells(y, z + 3) = d
Cells(y, z + 4) = e
Cells(y, z + 5) = f
Next f
Next e
Next d
Next c
Next b
Next a

MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Muharrem41 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 11-08-2017, 08:30   #2
Korhan Ayhan
Moderatör
 
Korhan Ayhan kullanıcısının avatarı
 
Giriş: 15/03/2005
Şehir: ANTALYA
Mesaj: 22,743
Excel Vers. ve Dili:
OFFICE 2013-2016 PRO TR
Varsayılan

Foruma kod eklerken lütfen CODE tagını kullanınız. Böylece eklediğiniz kodlar daha okunaklı ve belirgin olacaktır.

CODE tagı için mesaj yazdığınız edidör bölümünde diyez (#) işaretine basmanız yeterli olacaktır. Aşağıdaki gibi bir blok oluşacaktır. Siz kodu arasına yazmalısınız. (Not : Boşluklar olmayacak. Ben size tarif etmek için ekledim.)

[ CODE ]

[ / CODE ]

Ayrıca aynı konu için farklı başlıklar açıp yardım istemenize gerek yok. İlk başlığınız sonuçlanana kadar mesaj yazabilirsiniz.

http://www.excel.web.tr/showthread.p...wpost&t=165648
__________________
.
.
.

Soru sormadan önce forumumuzun aşağıdaki
bölümlerini incelediğinizde birçok sorunuza yanıt bulabilirsiniz.


Excel Dersanesi
Uygulamalı Excel Eğitimi
Excel İçin Örnek Uygulamalar
Video Dersane (***Altın Üyelere Özel***)

Lütfen sorularınızın çözümlendiğine dair geri dönüş mesajı yazınız...!
Lütfen yazım ve forum kurallarına uyalım...!
Lütfen sorularımızı açık ve net bir dille ifade edelim...!



FORUM KURALLARI
Korhan Ayhan Çevrimiçi   Alıntı Yaparak Cevapla
Eski 11-08-2017, 08:49   #3
askm
Altın Üye
 
Giriş: 04/06/2005
Şehir: k.maraş
Mesaj: 1,698
Excel Vers. ve Dili:
2010-2016
Varsayılan

6 rakama göre dediğiniz şekilde aşağıda yazdım. Yalnız öncelikle Sayfa2 ekleyip, bu sayfaya A sütununa olması gereken rakamları yazmanız gerekir.
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Sub Listele()
Dim x As Byte, y As Long, z As Long
Dim a As Byte, b As Byte, c As Byte, d As Byte, e As Byte, f As Byte, g As Byte
Dim s1, s2 As Worksheet
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")

s1.Cells.Clear
x = s2.Range("A" & Rows.Count).End(xlUp).Row
z = 1

For a = 1 To x
For b = a + 1 To x
For c = b + 1 To x
For d = c + 1 To x
For e = d + 1 To x
For f = e + 1 To x
y = y + 1
If y > 1048576 Then
y = 1
z = z + 7
End If
s1.Cells(y, z) = s2.Cells(a, 1)
s1.Cells(y, z + 1) = s2.Cells(b, 1)
s1.Cells(y, z + 2) = s2.Cells(c, 1)
s1.Cells(y, z + 3) = s2.Cells(d, 1)
s1.Cells(y, z + 4) = s2.Cells(e, 1)
s1.Cells(y, z + 5) = s2.Cells(f, 1)
Next f
Next e
Next d
Next c
Next b
Next a

MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
__________________
excel 2010- türkçe
askm Çevrimiçi   Alıntı Yaparak Cevapla
Eski 11-08-2017, 12:24   #4
Muharrem41
 
Giriş: 15/09/2016
Şehir: kocaeli
Mesaj: 33
Excel Vers. ve Dili:
türkçe 2007
Varsayılan hocam

bunu 5 Lİ VE 10 lu olarak yapmak istiyorum bunu nasıl yapacaĞım peki HOCAM
YATIĞINIZIN İÇİNDE EKLEME YAPABİLİYORMUYUZ

Bu mesaj en son " 11-08-2017 " tarihinde saat 12:35 itibariyle Muharrem41 tarafından düzenlenmiştir....
Muharrem41 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 11-08-2017, 14:21   #5
Muharrem41
 
Giriş: 15/09/2016
Şehir: kocaeli
Mesaj: 33
Excel Vers. ve Dili:
türkçe 2007
Varsayılan

hocam cevabınızı bekliyorum
Muharrem41 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 11-08-2017, 16:27   #6
askm
Altın Üye
 
Giriş: 04/06/2005
Şehir: k.maraş
Mesaj: 1,698
Excel Vers. ve Dili:
2010-2016
Varsayılan

a dan başlayıp f harfine kadar gitmiş, yani 6 harf siz bunu harf sayısını arttırarak ya da azaltarak değiştirebilirsiniz.5 için başına tek tırnak eklediğim kısımlar iptal manasında.
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Sub Listele()
Dim x As Byte, y As Long, z As Long
Dim a As Byte, b As Byte, c As Byte, d As Byte, e As Byte, f As Byte, g As Byte
Dim s1, s2 As Worksheet
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")

s1.Cells.Clear
x = s2.Range("A" & Rows.Count).End(xlUp).Row
z = 1

For a = 1 To x
For b = a + 1 To x
For c = b + 1 To x
For d = c + 1 To x
For e = d + 1 To x
'For f = e + 1 To x
y = y + 1
If y > 1048576 Then
y = 1
z = z + 7
End If
s1.Cells(y, z) = s2.Cells(a, 1)
s1.Cells(y, z + 1) = s2.Cells(b, 1)
s1.Cells(y, z + 2) = s2.Cells(c, 1)
s1.Cells(y, z + 3) = s2.Cells(d, 1)
s1.Cells(y, z + 4) = s2.Cells(e, 1)
's1.Cells(y, z + 5) = s2.Cells(f, 1)
'Next f
Next e
Next d
Next c
Next b
Next a

MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
__________________
excel 2010- türkçe
askm Çevrimiçi   Alıntı Yaparak Cevapla
Eski 11-08-2017, 19:25   #7
PLİNT
 
Giriş: 31/12/2014
Şehir: Gürün
Mesaj: 1,283
Excel Vers. ve Dili:
Excel 2010
Varsayılan

Merhaba
Sn.askm cevap vermiş ama alternatif olarak aşağıdaki dosyayıda denersiniz.
http://s6.dosya.tc/server10/zmxd31/KOM.zip.html
veya
https://www.dosyaupload.com/979D

"Sayfa1" "A" sütuna boşluk bırakmadan 10 satırdan az olmamak şartı ile elemanları girip, "B1" sütununa kaç seçim yapılacaksa (5 ile 10 arası) yazıp makroyu çalıştırınız.
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Sub Listele()
Dim kom()
Dim dc As Object
Dim fd As Variant
Dim a, b, c, d, e, f, i, x, n, j As Integer
Set s1 = Sheets("Sayfa1")
If s1.[B1] = "" And IsNumeric([B1]) = False And [B1] < 2 Or [B1] > 10 Then MsgBox "[B1] HÜCRESİNE 5 İLE 10 ARASI SAYI YAZINIZ": Exit Sub

sat = s1.Cells(Rows.Count, 1).End(3).Row
If sat < 5 Then MsgBox "A sütununda yeterli veri yok": Exit Sub
Set s2 = Sheets("Sayfa2")
Set dc = CreateObject("Scripting.Dictionary")
For x = 1 To sat
dc.Add x, s1.Cells(x, 1)
Next
tk = s1.[B1].Value
dg = sat - tk
s2.Activate
s2.Cells.Clear
ReDim kom(1 To tk, 1 To 65536)
i = 0: n = 1: j = 1: x = 0

For a = 1 To dg + 1
For b = a + 1 To dg + 2
For c = b + 1 To dg + 3
For d = c + 1 To dg + 4
For e = d + 1 To dg + 5

If tk = 5 Then GoTo 10:
For f = e + 1 To dg + 6
If tk = 6 Then GoTo 10:
For g = f + 1 To dg + 7
If tk = 7 Then GoTo 10:
For h = g + 1 To dg + 8
If tk = 8 Then GoTo 10:
For k = h + 1 To dg + 9
If tk = 9 Then GoTo 10:
For l = k + 1 To dg + 10

10:
fd = Array(a, b, c, d, e, f, g, h, k, l)
i = i + 1
For nn = 0 To tk - 1

ff = CDbl(fd(nn))
kom(nn + 1, i) = dc.Item(ff)
Next

If i = 65536 Then
x = x + 1
s2.Cells(n, j).Resize(i, tk) = Application.Transpose(kom)
If x = Rows.Count / 65536 Then
x = 0: n = 1: i = 0
j = j + tk
End If
s2.Cells(n + i, j).Select
n = n + i
 Erase kom: i = 0
ReDim kom(1 To tk, 1 To 65536)
 End If
 If tk = 9 Then GoTo 11:
 If tk = 8 Then GoTo 12:
 If tk = 7 Then GoTo 13:
 If tk = 6 Then GoTo 14:
 If tk = 5 Then GoTo 15:

Next:
11:
Next:
12:
Next:
13:
Next:
14:
Next:
15:
Next: Next: Next: Next: Next
If i > 0 Then s2.Cells(n, j).Resize(i, tk) = Application.Transpose(kom)
End Sub 
PLİNT Çevrimdışı   Alıntı Yaparak Cevapla
Eski 12-08-2017, 00:06   #8
Muharrem41
 
Giriş: 15/09/2016
Şehir: kocaeli
Mesaj: 33
Excel Vers. ve Dili:
türkçe 2007
Varsayılan Sayın Pilint

dosya yı indiremi yorum rica etsem mail atarmısınız
özelden mail adresimi attım
Muharrem41 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 12-08-2017, 00:30   #9
Muharrem41
 
Giriş: 15/09/2016
Şehir: kocaeli
Mesaj: 33
Excel Vers. ve Dili:
türkçe 2007
Varsayılan

Sayın Plint emeğine saglık
Muharrem41 Çevrimdışı   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 15:21


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Web Tasarım -- Beylikdüzü mali müşavir - Lingerie - Dyeing Machine - Karton Bardak- Çorlu Özel Eğitim- Site Yönetimi- Pronet Tekirdağ- Çorlu Kamera- Pronet Edirne- Pronet Kırklareli- Pronet Çerkezköy- Pronet Çorlu- Pronet Lüleburgaz- Pronet Keşan- Çorlu Araç Takip- Çorlu Su Arıtma- Gebze Emlak- Bakır Sülfat- Rampa- Rotary- Çorlu İnternet Sitesi- youngblood- Çorlu Sürücü Kursu- Çorlu Sandviç Panel- Şişli Avukat- Korona Test Kalemi- Çorlu Vinç- Çorlu Pimapen Tamiri- Çorlu Çelik Konstruksiyon- Çorlu Dans- Edirne Serbest Muhasebeci- Çorlu Etüt- İstanbul Botanik- Çorlu Sigorta-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden