• DİKKAT

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

Yan yana olan benzer hücreleri bulma

D ve E sütunundaki verileriniz metin formatında kalmış. Cdate eklendi. Deneyiniz.
Kod: 
Sub test()
    [BB3:CC1000].ClearContents
    For i = 3 To Cells(Rows.Count, "F").End(3).Row
        basladi = False
        bas_ = ""
        son_ = ""
        sut = 55
        Cells(i, "BB").Value = CDate(Cells(i, "D").Value) - TimeSerial(0, 15, 0) 'yeni ilave
        Cells(i, "BB").NumberFormat = "hh:mm" 'yeni ilave
        For ii = 6 To 53
            al = Cells(i, ii).Value
            If basladi = False Then
                If al = "*" Then
                    basladi = True
                  '  Cells(i, "BB").Value = Cells(1, ii).Value - TimeSerial(0, 15, 0)
                   ' Cells(i, "BB").NumberFormat = "hh:mm"
                End If
            Else
                If al = "_" Then
                    If bas_ = "" Then
                        bas_ = Cells(1, ii).Value
                    Else
                        son_ = Cells(1, ii).Value
                    End If
                Else
                    If son_ <> "" Then
                        Cells(i, sut).Value = bas_
                        Cells(i, sut + 1).Value = Cells(1, ii).Value
                        Cells(i, sut).Resize(, 2).NumberFormat = "hh:mm"
                        sut = sut + 3
                    End If
                    bas_ = ""
                    son_ = ""
                    sonYildiz = ii
                End If
            End If
        Next ii
        'Cells(i, sut).Value = Cells(1, sonYildiz).Value + TimeSerial(0, 15, 0)
        Cells(i, sut).Value = CDate(Cells(i, "E").Value) + TimeSerial(0, 15, 0) 'yeni ilave
        Cells(i, sut).NumberFormat = "hh:mm"
    Next i
End Sub
 
Teşekkür ederim. Süper oldu.

Öğrenmek için bir şeyi merak ettim. BB sütunundan sonra her 2 sütunda bir daraltılmış sütunlar var. Bu daraltılmış sütunları atlayıp geniş hücrelere nasıl verileri yazdırdık Ömer bey?
 
Kodlardaki;

sut = sut + 3

ile yapılıyor. İlk veriden örnek vereyim.

Cells(i, sut).Value = bas_ ( BC sütununa veri yazıyor, burada sut değeri = 55 )
Cells(i, sut + 1).Value = Cells(1, ii).Value ( +1 ile BD sütununa veri yazıyor, burada sut değeri = 55 + 1 = 56 )

sut değeri son yazımdan sonra 55 idi.

sut = sut+3
55=55+3
sut değeriminiz yeni veriyi yazmadan 58 değeri alır. Buda BF sütununa denk gelir. Atlama bu şekilde sut = sut+3 tanımıyla yapılıyor.
 
Ömer hocam merhaba.
C D ve E sütunların hücreleri boşsa BB sütunundan itibaren işlem yapmasa hücreleri boş bırakması için kodda nasıl bir düzenleme yapabiliriz?
C D ve E sütununda bulunan bazı hücreler boşsa BB sütununa ######## ve BC sütununa 00:15 yazıyor. Bunun önüne geçmek için yardımınıza ihtiyacım var.

Teşekkürler.
 
C,D,E sütunlarının herhangi biri boşsa işlem yapmaz.
Kod: 
Sub test()
    [BB3:CC1000].ClearContents
    For i = 3 To Cells(Rows.Count, "F").End(3).Row
        If WorksheetFunction.CountA(Cells(i, "C").Resize(1, 3)) = 3 Then
            basladi = False
            bas_ = ""
            son_ = ""
            sut = 55
            Cells(i, "BB").Value = CDate(Cells(i, "D").Value) - TimeSerial(0, 15, 0) 'yeni ilave
            Cells(i, "BB").NumberFormat = "hh:mm" 'yeni ilave
            For ii = 6 To 53
                al = Cells(i, ii).Value
                If basladi = False Then
                    If al = "*" Then
                        basladi = True
                      '  Cells(i, "BB").Value = Cells(1, ii).Value - TimeSerial(0, 15, 0)
                       ' Cells(i, "BB").NumberFormat = "hh:mm"
                    End If
                Else
                    If al = "_" Then
                        If bas_ = "" Then
                            bas_ = Cells(1, ii).Value
                        Else
                            son_ = Cells(1, ii).Value
                        End If
                    Else
                        If son_ <> "" Then
                            Cells(i, sut).Value = bas_
                            Cells(i, sut + 1).Value = Cells(1, ii).Value
                            Cells(i, sut).Resize(, 2).NumberFormat = "hh:mm"
                            sut = sut + 3
                        End If
                        bas_ = ""
                        son_ = ""
                        sonYildiz = ii
                    End If
                End If
            Next ii
            'Cells(i, sut).Value = Cells(1, sonYildiz).Value + TimeSerial(0, 15, 0)
            Cells(i, sut).Value = CDate(Cells(i, "E").Value) + TimeSerial(0, 15, 0) 'yeni ilave
            Cells(i, sut).NumberFormat = "hh:mm"
        End If
    Next i
End Sub
 
Teşekkürler.
Kod çok fena yavaşladı. 7500 satır veriyi 3-4 saniyede yapıyordu eski kod bu 1 saati bulacak :)
Application.ScreenUpdating = True Application.ScreenUpdating = False kullandım pek işe yaramadı. Eski koddan devam edeyim ben. Çok sağolun.
 
Excel'i açıp kapayınca bir anda hızlandı. Anlayamadım.
Elinize sağlık.
 
O kadar etkileyeceğiniz sanmıyorum. Başka bir durum olabilir mi?

Eklenen basit bir şart.

If WorksheetFunction.CountA(Cells(i, "C").Resize(1, 3)) = 3 Then
.
.
.
End if

Hesaplamayı pasif ve aktif yaptım.
Deneyiniz.
Kod: 
Sub test()
    Zaman = Timer
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    [BB3:CC100000].ClearContents
    For i = 3 To Cells(Rows.Count, "F").End(3).Row
        If WorksheetFunction.CountA(Cells(i, "C").Resize(1, 3)) = 3 Then
            basladi = False
            bas_ = ""
            son_ = ""
            sut = 55
            Cells(i, "BB").Value = CDate(Cells(i, "D").Value) - TimeSerial(0, 15, 0)
            Cells(i, "BB").NumberFormat = "hh:mm"
            For ii = 6 To 53
                al = Cells(i, ii).Value
                If basladi = False Then
                    If al = "*" Then
                        basladi = True
                    End If
                Else
                    If al = "_" Then
                        If bas_ = "" Then
                            bas_ = Cells(1, ii).Value
                        Else
                            son_ = Cells(1, ii).Value
                        End If
                    Else
                        If son_ <> "" Then
                            Cells(i, sut).Value = bas_
                            Cells(i, sut + 1).Value = Cells(1, ii).Value
                            Cells(i, sut).Resize(, 2).NumberFormat = "hh:mm"
                            sut = sut + 3
                        End If
                        bas_ = ""
                        son_ = ""
                        sonYildiz = ii
                    End If
                End If
            Next ii
            Cells(i, sut).Value = CDate(Cells(i, "E").Value) + TimeSerial(0, 15, 0)
            Cells(i, sut).NumberFormat = "hh:mm"
        End If
    Next i
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
    MsgBox "Hesaplama Tamamlandı." & Chr(10) & "Zaman:" & Format(Timer - Zaman, "0.00") & " saniye"
End Sub
 
Exceli açıp kapayınca hızlandı anlamadım bende. Yoruldu herhalde :D
Teşekkürler.
 
Ömer' Alıntı:
O kadar etkileyeceğiniz sanmıyorum. Başka bir durum olabilir mi?

Eklenen basit bir şart.

If WorksheetFunction.CountA(Cells(i, "C").Resize(1, 3)) = 3 Then
.
.
.
End if

Hesaplamayı pasif ve aktif yaptım.
Deneyiniz.
Kod: 
Sub test()
    Zaman = Timer
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    [BB3:CC100000].ClearContents
    For i = 3 To Cells(Rows.Count, "F").End(3).Row
        If WorksheetFunction.CountA(Cells(i, "C").Resize(1, 3)) = 3 Then
            basladi = False
            bas_ = ""
            son_ = ""
            sut = 55
            Cells(i, "BB").Value = CDate(Cells(i, "D").Value) - TimeSerial(0, 15, 0)
            Cells(i, "BB").NumberFormat = "hh:mm"
            For ii = 6 To 53
                al = Cells(i, ii).Value
                If basladi = False Then
                    If al = "*" Then
                        basladi = True
                    End If
                Else
                    If al = "_" Then
                        If bas_ = "" Then
                            bas_ = Cells(1, ii).Value
                        Else
                            son_ = Cells(1, ii).Value
                        End If
                    Else
                        If son_ <> "" Then
                            Cells(i, sut).Value = bas_
                            Cells(i, sut + 1).Value = Cells(1, ii).Value
                            Cells(i, sut).Resize(, 2).NumberFormat = "hh:mm"
                            sut = sut + 3
                        End If
                        bas_ = ""
                        son_ = ""
                        sonYildiz = ii
                    End If
                End If
            Next ii
            Cells(i, sut).Value = CDate(Cells(i, "E").Value) + TimeSerial(0, 15, 0)
            Cells(i, sut).NumberFormat = "hh:mm"
        End If
    Next i
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
    MsgBox "Hesaplama Tamamlandı." & Chr(10) & "Zaman:" & Format(Timer - Zaman, "0.00") & " saniye"
End Sub
Genişletmek için tıkla ...

Ömer Bey merhaba.
Bir derdim var yardımcı olabilirmisiniz?
Kod verileri BB sütunundan itibaren 2 sütunu doldursa sonra 2 sütunu boş bıraksa sonra yine tekrar 2 sütunu doldursa ve bu böyle gitse nasıl bir düzenleme yapabiliriz?
Bir de boş sütunlardan ilki formüllü ardından gelen tamamen boş bir sütun olacak.
2 dolu 2 boş veri işlerken boş sütunlara hiç dokunmadan diğer sütuna atlaması ile ilgili bir düzenleme de yapabilir misiniz?
 
Atlama kısmını #24. mesajda yazmıştım.

sut = sut + 3

yerine;

sut = sut + 4

yazmanız yeterli olur.

Silme içinse;

[BB3:CC100000].ClearContents

yerine

On Error Resume Next
[BB3:CC10000].SpecialCells(xlCellTypeConstants, 23).ClearContents

yazarak deneyiniz.
 
Ömer' Alıntı:
Atlama kısmını #24. mesajda yazmıştım.

sut = sut + 3

yerine;

sut = sut + 4

yazmanız yeterli olur.

Silme içinse;

[BB3:CC100000].ClearContents

yerine

On Error Resume Next
[BB3:CC10000].SpecialCells(xlCellTypeConstants, 23).ClearContents

yazarak deneyiniz.
Genişletmek için tıkla ...

Merhaba.
Dediğinizi konuya yorum yazmadan önce yapmıştım zaten. Olmadığı için tekrar yardım istedim.
Hatta
Cells(i, sut + 1).Value = Cells(1, ii).Value
ile
sut = sut + 4
satırlarındaki + rakamlarının çeşitli kombinasyonlarını da denedim düzgün dağılım yapmıyor.

sut = sut + 4 dersek ilk 3 sütunu dolduruyor sonra 2 boşluk bırakıyor sonra 2 dolu 2 boş yapıyor. Buda tabloyu baştan aşağı bozuyor :)
2 dolu 2 boş yapması için başka bir şeyler eklememiz gerekiyor diye düşünüyorum.
 
Kumpasta' Alıntı:
2- İlgili satırın ilk yıldızının bulunduğu saati BB hücresine ve yine aynı satırın son yıldızını da yan yana kaç gurup varsa o gurubun sonundaki ilk boş
Genişletmek için tıkla ...

İlk 3 sütun dediğinizin ilki BB sütunu oluyor. Buda sizin #3. numaralı mesajdaki isteğiniz oluyor.
Yani ilk sütun sabit geliyor, daha sonra sizin istediğiniz gibi 2 sütun geliyor, 2 boş bırakıyor.... şeklinde ilerliyor.
 
Tamam hocam teşekkür edeirm.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst