VBA kodunu tüm sayfalarda çalıştırmak

[cicosz]

Merhaba,

Linteki dosyayla ilgili aşağıdaki işlemleri yapmam gerekiyor.
1-Kontak Açıldı ve Kontak Kapalı haricindeki tüm satırları silme,
2-Geriye kalan satırlarda gün içindeki max değerden min değeri çıkarmak, (Amaç günlük Km'yi bulmak.)
3-Sonra günlük km değerini sayfanın sağına gün-km şeklinde yazdırmak.

Bu şekilde yaklaşık 1000 sayfa var. Aşağıdaki kod ile sadece etkin sayfadaki verilerde işlem yapabiliyorum devamını getiremiyorum. Yardımlarınız için şimdiden teşekkürler.
Dosya Linki: https://www.dosya.tc/server22/9prjy6/Arac_Animasyon_-_Kopya.xlsx.html

Sub SatirSil()
Dim LR As Long, i As Long
LR = Range("E" & Rows.Count).End(xlUp).Row
For i = LR To 2 Step -1
If Not (Range("E" & i).Value Like "*Kontak Açıldı*" Or Range("E" & i).Value Like "*Kontak Kapalı*") Then Rows(i).Delete
Next i
End Sub

 

[mancubus]

E sütununda silincek satırların Kontak kelimesinin içermemesi kaydıyla aşağıdaki gibi bir şey kullanılabilir.
dosyayı görme şansım olmadığı için Max Min değerlerin D sütununda (yani 4. sütun) olduğunu varsayarak hesap yaptım. sütun numarasını düzeltmek gerekir.
tablonun en sağında bir sütun boş bıraktıktan sonra 2. satıra Max - Min rakamını yazması gerekir.
Gün verisi nereden gelir göremediğim için onu koda ayrıca eklemek lazım.

Sub xlTR_182325()

    Dim i As Long, SonSut As Long
  
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    For i = 1 To Worksheets.Count
        With Worksheets(i)
            .AutoFilterMode = False
            .Cells(1).AutoFilter Field:=5, Criteria1:="<>*Kontak*", Operator:=xlAnd
            .AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .AutoFilterMode = False
            SonSut = .Cells(1, .Columns.Count).End(xlToLeft).Column
            .Cells(2, SonSut + 2).Value = Application.Max(.Columns(4)) - Application.Min(.Columns(4))
        End With
    Next i

    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

her zamanki gibi dosyanın bir yedeğini alıp kodu o dosyada bir modüle kopyaladıktan sonra çalıştıralım. ben genellikle makro için gerekli değil ise tüm diğer dosyaların kapatılmasının öneririm.

 

[cicosz]

Öncelikle teşekkürler.
Liste şu şekilde gidiyor. Zaman sütununda tarih 9-13 eylül arası. zaman sütunundaki(F) veriler de standart tarih biçiminde değil o yüzden onu filtreleyemedim. 9 unu tarayıp max-min işlemi yapıp 9.09.2019 hücresinin altına yazdırmam gerekiyor.

Sıra    Plaka    Tip                Zaman        Hız km/sa    Katedilen Mesafe km                               
0    34 AP 034    Kontrol Mesajı    9 09 2019 00:57    0    212.998,20                           9.09.2019    10.09.2019    11.09.2019    12.09.2019    13.09.2019   
1    34 AP 034    Kontrol Mesajı    9 09 2019 03:57    0    212.998,20                               
88    34 AP 034    Periyodik Mesaj    9 09 2019 08:34    0    213.009,20                               
89    34 AP 034    Kontak Kapalı    9 09 2019 08:35    0    213.009,20                               
90    34 AP 034    Kontrol Mesajı    9 09 2019 11:34    0    213.009,20                               
91    34 AP 034    Kontak Açıldı    9 09 2019 12:32    0    213.009,20                               
92    34 AP 034    Kontak Kapalı    9 09 2019 12:33    0    213.009,20                               
93    34 AP 034    Kontak Açıldı    9 09 2019 14:54    0    213.009,20                               
94    34 AP 034    Açı Bilgisi    9 09 2019 14:55    12    213.009,20                               
95    34 AP 034    Açı Bilgisi    9 09 2019 14:55    17    213.009,20                               
96    34 AP 034    Açı Bilgisi    9 09 2019 14:55    24    213.009,30                               
97    34 AP 034    Açı Bilgisi    9 09 2019 14:55    16    213.009,30                               
98    34 AP 034    Periyodik Mesaj    9 09 2019 14:55    7    213.009,30                               
99    34 AP 034    Açı Bilgisi    9 09 2019 14:55    17    213.009,30                               
100    34 AP 034    Açı Bilgisi    9 09 2019 14:56    85    213.009,90                               
101    34 AP 034    Periyodik Mesaj    9 09 2019 14:56    76    213.010,50                               
102    34 AP 034    Açı Bilgisi    9 09 2019 14:57    56    213.011,00                               
103    34 AP 034    Periyodik Mesaj    9 09 2019 14:57    47    213.011,30                               
104    34 AP 034    Açı Bilgisi    9 09 2019 14:58    64    213.011,90                               
105    34 AP 034    Periyodik Mesaj    9 09 2019 14:58    75    213.012,40                               
106    34 AP 034    Açı Bilgisi    9 09 2019 14:59    65    213.013,20                               
107    34 AP 034    Açı Bilgisi    9 09 2019 14:59    69    213.013,50

 

[mancubus]

asıl veri başka bir uygulamadan txt vb dosya formatında mı geliyor.

 

[mancubus]

dosyanın yedeğinde şu kodu deneyin.
tarih bilgisini içeren metinde ifadeler D sütununda, katedilen mesafeler F sütununda

Sub xlTR_182325()

    Dim i As Long,  j As Long, SonSut As Long, SonSat As Long
    Dim dgrMax As Double, dgrMin As Double
    Dim TrhUnqArr
    Dim dic As Object
    Dim cl As Range
   
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    For i = 1 To Worksheets.Count
        With Worksheets(i)
            .AutoFilterMode = False
           
            .Cells(1).AutoFilter Field:=3, Criteria1:="<>*Kontak*", Operator:=xlAnd
            .AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .AutoFilterMode = False
           
            SonSat = .Cells(.Rows.Count, 1).End(xlUp).Row
            SonSut = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
            Set dic = CreateObject("Scripting.Dictionary")
            For Each cl In .Range("D2:D" & SonSat)
                dic(Left(cl, InStrRev(cl, " ") - 1)) = 1
            Next cl
            TrhUnqArr = dic.Keys
           
            For j = LBound(TrhUnqArr) To UBound(TrhUnqArr)
                .Cells(2, SonSut + 2 + j) = Replace(TrhUnqArr(j), " ", "/")
                .Cells(1).AutoFilter Field:=4, Criteria1:="=*" & TrhUnqArr(j) & "*", Operator:=xlAnd
                dgrMax = Application.Max(.Range("F:F").SpecialCells(xlCellTypeVisible))
                dgrMin = Application.Min(.Range("F:F").SpecialCells(xlCellTypeVisible))
                .Cells(3, SonSut + 2 + j) = dgrMax - dgrMin
            Next j
           
            .AutoFilterMode = False
        End With
       
        Erase TrhUnqArr
        Set dic = Nothing
    Next i

    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

 

[mancubus]

kodda bir satırı atlamışım. onu ekledim.