Yan yana olan benzer hücreleri bulma

Kumpasta · 12 Kasım 2020

Örnek dosyayı ekledim Ömer bey.

Ömer · 12 Kasım 2020

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

Kumpasta · 12 Kasım 2020

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?

Ömer · 12 Kasım 2020

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.

Kumpasta · 12 Kasım 2020

Teşekkür ederim zaman ayırıp yardım eden herkese.

Kumpasta · 13 Kasım 2020

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

Ömer · 13 Kasım 2020

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

Kumpasta · 13 Kasım 2020

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.

Kumpasta · 13 Kasım 2020

Excel'i açıp kapayınca bir anda hızlandı. Anlayamadım.
Elinize sağlık.

Ömer · 13 Kasım 2020

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

Kumpasta · 13 Kasım 2020

Exceli açıp kapayınca hızlandı anlamadım bende. Yoruldu herhalde

Teşekkürler.

Kumpasta · 5 Ocak 2021

Ö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

Ö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?

Ömer · 5 Ocak 2021

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.

Kumpasta · 6 Ocak 2021

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

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.

Ömer · 7 Ocak 2021

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ş

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

Kumpasta · 9 Ocak 2021

Tamam hocam teşekkür edeirm.

Yan yana olan benzer hücreleri bulma

Kumpasta

Ekli dosyalar

Ömer

Moderatör

Kumpasta

Ömer

Moderatör

Kumpasta

Kumpasta

Ömer

Moderatör

Kumpasta

Kumpasta

Ömer

Moderatör

Kumpasta

Kumpasta

Ömer

Moderatör

Kumpasta

Ömer

Moderatör

Kumpasta