VBA Çoklu For Döngüsü

Greenblacksea53

Altın Üye
Katılım
5 Ocak 2019
Mesajlar
548
Excel Vers. ve Dili
Ofis 365 Tr
Selam arkadaşlar,

A sütununda a,b,c verileri var, B sütununda 300 adet saat verisi var (11:00 gibi), C sütununda (1 den 10 a rakamlar var) F sütununda da yine 300 adet saat verisi var. İstediğim şu F sütundaki ilk veriyi b sütununda arasın eşleşenler verilerin b sütundaki ve a sütundaki verileri f sütunun yanına yazsın(ilk b sütundaki verileri sonra a sütundaki verileri yazacak). Eğer birden fazla eşleşme varsa diğer sütuna doğru devam etsin . (11:00, 2 adet varsa H I sütuna İlk bulunan verinin B sütunun değeri sonra A sütunun değeri ikinci bulunan değer J k sütununa yazsın gibi.
Tşk ederim kolay gelsin.
 

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,181
Excel Vers. ve Dili
Ofis 365 Türkçe
Merhaba,

Örnek dosyanızı paylaşım sitelerinden birine yüklerseniz çözüme daha hızlı ulaşabilirsiniz.
 

Greenblacksea53

Altın Üye
Katılım
5 Ocak 2019
Mesajlar
548
Excel Vers. ve Dili
Ofis 365 Tr
Link

Excelde açıklama yaptım manuel olarak girdim. ne yapmak istediğimi anlatmak adına
Kolay gelsin tşk ederim.
 

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,616
Excel Vers. ve Dili
Microsoft 365 Tr-64
Module1 içindeki kodları her çalıştırdığınızda işlemi yapacaktır.
Ancak dosyanızda oldukça sıkıntılar var. Bu sebeple
1. Boş Satırları aralardan kaldırdım
2. B sütunundaki 1-2-3- gibi ara başlıkların olduğu sütunları da kaldırdım
3. Bazı saat girişlerinde hatalar vardı ve habire kodlar hata veriyordu. Bu sebeple kod içinde B sütununda var olan verileri doğru saatlerle değişiyorum
4. Kenarlıklarınızı da kaldırdım. Arzu ederseniz forudma örnekleri var yeniden kenarlık yapılabilir. Sonuc tablosuna göre. Zira satır sayısı değişince kenarlıklar çirkin kalmasın.
5. Başka da neler değiştim aklımda kalmadı.

C++:
Sub BulYaz()

Dim Dizi As Object, Veri As Variant
Dim son As Long, sonB As Long, x As Long, i As Long
Dim Böl As Double
Dim Sh As Worksheet
Dim Yaz
    Application.ScreenUpdating = False
    Set Sh = Worksheets("GİRİŞ ARA ÇIKIŞ")
    sonB = Sh.Range("B" & Rows.Count).End(3).Row
    Set Dizi = CreateObject("System.Collections.ArrayList")
    Veri = Sh.Range("B2:B" & sonB).Value
    Sh.Range("D:K").UnMerge
    Sh.Range("D2:K" & Rows.Count).ClearContents
    For x = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(x, 1) <> "" Then
            Yaz = Format(CDbl(Veri(x, 1)), "hh:mm")
            Sh.Range("B" & x + 1) = Yaz
            If Not Dizi.Contains(Yaz) Then Dizi.Add Yaz
        End If
    Next
   Dizi.Sort
    
    Böl = Dizi.Count / 2
    If Int(Böl) <> Böl Then Böl = Böl + 0.5
    
    For i = 1 To Böl
        Range("D" & 2 * i) = Dizi.Item(i - 1)
        Range("D" & 2 * i, "D" & (2 * i) + 1).Merge
    Next i
    For i = 1 To Int(Dizi.Count / 2)
        Range("K" & 2 * i) = Dizi.Item(i - 1 + Böl)
        Range("K" & 2 * i, "K" & (2 * i) + 1).Merge
    Next i

    
    
Dim Bul As Range, k As Integer
Dim Ara As Date
    
    For i = 2 To 2 * Böl Step 2
        k = 5
        Ara = CDate(Range("D" & i))
        Set Bul = Sh.Range("B1:B" & sonB).Find(Ara)
        If Bul Is Nothing Then GoTo Devam1
        ilkadres = Bul.Address
        Do

            Sh.Cells(i, k) = Bul.Offset(0, 1)
            Sh.Cells(i + 1, k) = Bul.Offset(0, -1)
            k = k + 1
            Set Bul = Sh.Range("B1:B" & sonB).FindNext(Bul)
        Loop While Bul.Address <> ilkadres
Devam1:
    Next i
    
    For i = 2 To 2 * Int(Dizi.Count / 2) Step 2
        k = 12
        Ara = CDate(Range("K" & i))
        Set Bul = Sh.Range("B1:B" & sonB).Find(Ara)
        If Bul Is Nothing Then GoTo Devam2
        ilkadres = Bul.Address
        Do

            Sh.Cells(i, k) = Bul.Offset(0, 1)
            Sh.Cells(i + 1, k) = Bul.Offset(0, -1)
            k = k + 1
            Set Bul = Sh.Range("B1:B" & sonB).FindNext(Bul)
        Loop While Bul.Address <> ilkadres
Devam2:
    Next i
  
    Set Dizi = Nothing: Set Bul = Nothing: Veri = ""
    Application.ScreenUpdating = True
End Sub
Harici indirme linki.
https://dosya.co/lv3d9e0hq5c6/BulYaz_Cevap.xlsm.html
 

Ekli dosyalar

Greenblacksea53

Altın Üye
Katılım
5 Ocak 2019
Mesajlar
548
Excel Vers. ve Dili
Ofis 365 Tr
Mükemmel olmuş elinize sağlık hocam, 00:00 saatleri en başta değil de en sonda gösterebilme şansımız var mı ?
Hocam bu arada (Set Dizi = CreateObject("System.Collections.ArrayList")) satırda hata verdi excel ile mi alakalı yada eklenti mi yükleme yapmam lazım ?
 

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,616
Excel Vers. ve Dili
Microsoft 365 Tr-64
Bendeki dosyayı aynen kullanıyorsnaız vermemesi lazım.
Hata ne yazıyor ?

En başta hangi saatler görülecek ? 01:00 dan sonrası mı?
Bunun yerine 23:59 dan aşağı da yapabiliriz
 

Greenblacksea53

Altın Üye
Katılım
5 Ocak 2019
Mesajlar
548
Excel Vers. ve Dili
Ofis 365 Tr
Run time error'-2146232576 (80131700)
Automation error
hatası veriyor hatayı geçince diğer hatalar buna bağlı mı bilemiyorum.
Sadece geliştiriciden makroyu run yaptım
 

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,616
Excel Vers. ve Dili
Microsoft 365 Tr-64
Gönderdiğim dosyayı indirip açtım, kodlar çalıştı. hata vermedi.
Referanslardan işaretli olanlar ekte. Kontrol edin.
229648
 

Greenblacksea53

Altın Üye
Katılım
5 Ocak 2019
Mesajlar
548
Excel Vers. ve Dili
Ofis 365 Tr
Bu arada Saat varsa 10:00 gibi başlasın ama genelde 11:00 de başlıyor 10:00 sonrası olacak şekilde düzelme şansı olursa daha iyi olur
 

Greenblacksea53

Altın Üye
Katılım
5 Ocak 2019
Mesajlar
548
Excel Vers. ve Dili
Ofis 365 Tr
Aynı sürüm ama ben 32bit kullanıyorum ondan fark eder mi acaba? Sizde çalışan bende hataya sebep olan şey nedir acaba?
 

Greenblacksea53

Altın Üye
Katılım
5 Ocak 2019
Mesajlar
548
Excel Vers. ve Dili
Ofis 365 Tr
Hocam ben bunu excel fonksiyonları ile yaptım ama inanılmaz derece sütun kullandım dolayısıyla dosya boyutu büyüdü. Saat sorun değil uğraştıracaksa sadece istekti. Peki hata vermesinin nedeni ne olabilir? Çok şaşırdım Özel mesajla teamwier id verebilirim sorunu çözebilirsek
 

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,616
Excel Vers. ve Dili
Microsoft 365 Tr-64
Dizi.Sort satırından hemen sonra aşağıdakileri ilave edin.
C++:
        Do Until Hour(Dizi.Item(0)) >= 10
        Dizi.Add Dizi.Item(0)
        Dizi.RemoveAt 0
        Loop
Devamında aşağıdaki satır olacak
Böl = Dizi.Count / 2
 

Greenblacksea53

Altın Üye
Katılım
5 Ocak 2019
Mesajlar
548
Excel Vers. ve Dili
Ofis 365 Tr
Hocam size fikir vermesi adına söylüyorum
Set Dizi = CreateObject("System.Collections.ArrayList") satırın üstüne On Error Resume Next yazınca başka hata vermiyor ama sayfadaki saatler gidiyor.

ikinci yaptığım şey On Error Resume Next i silip Dim CreateObject as object ekledim bu sefer bu hatayı verdi
Run time error '91':
Object variable or With block variable not set umarım size fikir verir
 

Greenblacksea53

Altın Üye
Katılım
5 Ocak 2019
Mesajlar
548
Excel Vers. ve Dili
Ofis 365 Tr
Hocam büyük ihtimalle Windows 11 kullanmamdan dolayı kaynaklanıyor linki inceledim, hatanın sebebi Bunun nedeni doğru .Net Framework sürümünün yüklü olmamasıdır. Doğru sürüm 3.5'tir. 4.7 gibi daha yeni bir sürüme sahip olmanız önemli değildir, 3.5 yüklü olmalıdır. İş pcde deneyecem herşey için teşekkürler bilgi veririm. Elinize sağlık müthiş bir iş çıkardınız
 

Greenblacksea53

Altın Üye
Katılım
5 Ocak 2019
Mesajlar
548
Excel Vers. ve Dili
Ofis 365 Tr
Hocam aynı hatayı alanlar olabilir belki Net Framework3i5 u yükledim sorun düzeldi Saatte artık 10'dan başlıyor tekrar teşekkür ederim.
 

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,616
Excel Vers. ve Dili
Microsoft 365 Tr-64
Sorunun çözüldüğüne sevindim.
Kolay gelsin.
 
Üst