VBA Çoklu For Döngüsü

[Greenblacksea53]

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]

Merhaba,

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

 

[Greenblacksea53]

Link

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

 

[Greenblacksea53]

Önceki link Google docs ta açıyor sanırsam Buraya indirme olarak koydum

 

[ÖmerFaruk]

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ı.

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

 

[Greenblacksea53]

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]

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]

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]

Gönderdiğim dosyayı indirip açtım, kodlar çalıştı. hata vermedi.
Referanslardan işaretli olanlar ekte. Kontrol edin.

 

[Greenblacksea53]

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]

Resim flu referasnları yazma şansınız var mı kontrol etmek için

 

[Greenblacksea53]

Aynı sürüm ama ben 32bit kullanıyorum ondan fark eder mi acaba? Sizde çalışan bende hataya sebep olan şey nedir acaba?

 

[ÖmerFaruk]

Resim linki.
https://dosya.co/00icqjxekv2d/Ekran_Alıntısı.JPG.html

Şimdi bu saatin 10 dan başlaması varya, uğraştıracak.

 

[Greenblacksea53]

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]

Dizi.Sort satırından hemen sonra aşağıdakileri ilave edin.

        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]

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

 

[ÖmerFaruk]

Yaptıkların doğru değil.
Ama hata neden var anlamış da değilim.
Dosya bende çalışıyor. Bilgisayarım 64 bit.
Benim gönderdiğim orjinal dosyanın hata vermemesi gerekir.

Konuyu bilen birisi yardımcı olabilir belki.

İnceleyebilirsiniz vaktiniz varsa.
https://excelmacromastery.com/vba-arraylist/#Download_the_Source_Code

 

[Greenblacksea53]

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]

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]

Sorunun çözüldüğüne sevindim.
Kolay gelsin.