Kriterlere göre listeden sonuç elde etme

[modoste]

merhaba sayın hocalarım
ekli listede seçilen bir tarihte seçilen bir malzeme cinsine göre kamyonların tartım bilgileri bulunmaktadır,

peşpeşe 2 sefer arasında 30 dakikadan daha az zaman varsa bunların bulunması gerekmektedir. (bu zaman değişkenleşecek ilerde)

ekli dosyamda kriterleri açıkladım.
Çözüm Makrolu da olabilir. fonksiyonlarlada

 

[tamer42]

merhaba sayın hocalarım
ekli listede seçilen bir tarihte seçilen bir malzeme cinsine göre kamyonların tartım bilgileri bulunmaktadır,

peşpeşe 2 sefer arasında 30 dakikadan daha az zaman varsa bunların bulunması gerekmektedir. (bu zaman değişkenleşecek ilerde)

ekli dosyamda kriterleri açıkladım.
Çözüm Makrolu da olabilir. fonksiyonlarlada

Makro ile çözülmüş Ekli dosyayı inceler misiniz,

Sub Test()
Dim SH As Worksheet
Dim dak As Double
Dim plaka As String
Dim x As Long
Dim i As Long, j As Long
Dim LR As Long, r As Long

Set SH = Sayfa1

LR = SH.Cells(SH.Rows.Count, "E").End(xlUp).Row

SH.Range("Q:Q").ClearContents

For i = 21 To LR

plaka = SH.Range("E" & i).Value

    For j = i + 1 To LR
   
        If SH.Range("E" & j) = plaka Then
                dak1 = SH.Range("N" & i).Value + SH.Range("O" & i).Value
                dak2 = SH.Range("N" & j).Value + SH.Range("O" & j).Value
                dak = dak2 - dak1
                If dak * 1440 < 24 Then          
                    SH.Range("Q" & i).Value = j
                    SH.Range("Q" & j).Value = i
                End If
           GoTo devam
        End If
   
    Next j

devam:
plaka = ""
dak = 0

Next i

SH.Range("Z21:AC" & LR).ClearContents

x = 21

For i = 21 To LR

    If SH.Range("Q" & i) <> "" Then
   
    r = SH.Range("Q" & i).Value
       
        SH.Range("Z" & x) = SH.Range("E" & i)
        SH.Range("AA" & x) = SH.Range("G" & i)
        SH.Range("AB" & x) = SH.Range("N" & i)
        SH.Range("AC" & x) = SH.Range("O" & i)
       
        SH.Range("Z" & x + 1) = SH.Range("E" & r)
        SH.Range("AA" & x + 1) = SH.Range("G" & r)
        SH.Range("AB" & x + 1) = SH.Range("N" & r)
        SH.Range("AC" & x + 1) = SH.Range("O" & r)
       
        SH.Range("Q" & r).ClearContents
       
    x = x + 2
   
    End If

Next i

Set SH = Nothing

MsgBox "İşlem Tamam", vbOKOnly, "Bilgi"

End Sub

 

[modoste]

sayın tamer42 çözüm için teşekkür ederim

ancak çözüm excelinde malzeme adının aynı olması gerekiyor


06DEL576 nın malzeme bilgilerinde B var altında A var bu hatalı aynı şekilde 06DEY158 in malzeme adı önce A altında B olmuş bunlar hatalı
ve tarih kriteri 07.09.2022 sadece bu tarih için olmalı
ben bu makroyu çalıştırırken TARİH = 09.09.2022 yazacam MALZEME = A yazacam ve makroyu çalıştıracam
en soldaki 1-2-1 gibi sayıların bir önemi yok olmasa da olur

 

[tamer42]

sayın tamer42 çözüm için teşekkür ederim

ancak çözüm excelinde malzeme adının aynı olması gerekiyor

Ekli dosyayı görüntüle 245058
06DEL576 nın malzeme bilgilerinde B var altında A var bu hatalı aynı şekilde 06DEY158 in malzeme adı önce A altında B olmuş bunlar hatalı
ve tarih kriteri 07.09.2022 sadece bu tarih için olmalı
en soldaki 1-2-1 gibi sayıların bir önemi yok olmasa da olur

Buyurun, dosya güncellenmiştir.

sol tarafta yazan 1 ve 2 nin kod ile bir alakası yok,
kendiniz düzenleyebilirsiniz

Sub Test()
Dim SH As Worksheet
Dim dak As Double
Dim plaka As String
Dim malzeme As String
Dim x As Long
Dim i As Long, j As Long
Dim LR As Long, r As Long


Set SH = Sayfa1


LR = SH.Cells(SH.Rows.Count, "E").End(xlUp).Row

SH.Range("Q:Q").ClearContents

For i = 21 To LR

plaka = SH.Range("E" & i).Value
malzeme = SH.Range("G" & i).Value

    For j = i + 1 To LR
  
        If SH.Range("E" & j) = plaka And SH.Range("G" & j) = malzeme Then
                dak1 = SH.Range("N" & i).Value + SH.Range("O" & i).Value
                dak2 = SH.Range("N" & j).Value + SH.Range("O" & j).Value
              
                dak = dak2 - dak1
                If dak * 1440 < 24 Then
                  
                    SH.Range("Q" & i).Value = j
                    SH.Range("Q" & j).Value = i
                  
                End If
           GoTo devam
        End If
      

    Next j

devam:
plaka = ""
malzeme = ""
dak = 0

Next i

SH.Range("Z21:AC" & LR).ClearContents

x = 21

For i = 21 To LR

    If SH.Range("Q" & i) <> "" Then
  
    r = SH.Range("Q" & i).Value
      
        SH.Range("Z" & x) = SH.Range("E" & i)
        SH.Range("AA" & x) = SH.Range("G" & i)
        SH.Range("AB" & x) = SH.Range("N" & i)
        SH.Range("AC" & x) = SH.Range("O" & i)
      
        SH.Range("Z" & x + 1) = SH.Range("E" & r)
        SH.Range("AA" & x + 1) = SH.Range("G" & r)
        SH.Range("AB" & x + 1) = SH.Range("N" & r)
        SH.Range("AC" & x + 1) = SH.Range("O" & r)
      
        SH.Range("Q" & r).ClearContents
      
    x = x + 2
  
    End If

Next i

Set SH = Nothing

MsgBox "İşlem Tamam", vbOKOnly, "Bilgi"

End Sub

 

[modoste]

sayın Hocam
işin içine başlangıç tarihi ve bitiş tarihini de katarak sorumu tekrar yenilemek istiyorum
Makro Çalıştırmadan önce AA13 hücresine başlangıç tarihini yazılacak, AA14 hücresine bitiş tarihi yazılacak, AA15 hücresine de malzeme adı yazılacak ve ben ALT+F8 ile çalıştırdığımda sonuçları görmek istiyorum

kodu revize edebilir miyiz.

 

[tamer42]

k sorumu tekrar yenilemek istiyorum
Makro Çalıştırmadan önce AA13 hücresine başlangıç tarihini yazılacak, AA

ayın Hocam
işin içine başlangıç tarihi ve bitiş tarihini de katarak sorumu tekrar yenilemek istiyorum
Makro Çalıştırmadan önce AA13

sayın Hocam
işin içine başlangıç tarihi ve bitiş tarihini de katarak sorumu tekrar yenilemek istiyorum
Makro Çalıştırmadan önce AA13 hücresine başlangıç tarihini yazılacak, AA14 hücresine bitiş tarihi yazılacak, AA15 hücresine de malzeme adı yazılacak ve ben ALT+F8 ile çalıştırdığımda sonuçları görmek istiyorum

kodu revize edebilir miyiz.

Buyurun...

 

[modoste]

sayın hocam son bir eklemem daha olacak
az önce merkezden arkadaşım aradı zaman kriterini (bu sorumda 30 dakika) değiştirme durumunu da AA16 hücresinde belirtebilir miyiz

buraya 20,30,45,55 gibi dakikayı manuel yapabilir miyiz

sizi yordum hocam çok teşekkür ederim

 

[modoste]

1. hatalı fiş grubunu bulduk hocam, fiş resimlerini ekledim 19.09.2022 de makro sonucu ilk tarih

 

[modoste]

7 nolu mesajımdaki dakika kriterini de makroya eklemenizi bekliyorum hocam

 

[tamer42]

sayın hocam son bir eklemem daha olacak
az önce merkezden arkadaşım aradı zaman kriterini (bu sorumda 30 dakika) değiştirme durumunu da AA16 hücresinde belirtebilir miyiz
Ekli dosyayı görüntüle 245063
buraya 20,30,45,55 gibi dakikayı manuel yapabilir miyiz

sizi yordum hocam çok teşekkür ederim

Buyurun...

 

[tamer42]

1. hatalı fiş grubunu bulduk hocam, fiş resimlerini ekledim 19.09.2022 de makro sonucu ilk tarih
Ekli dosyayı görüntüle 245064

Burada ne demek istediğiniz anlayamadım, yalnız bir önceki kodda 24 dak. üzerinden hesaplamışız, yeni farkeettim

yalnız son dosyada bunu dinamik hale getirdik

If dak * 1440 < 24 Then

 

[tamer42]

7 nolu mesajımdaki dakika kriterini de makroya eklemenizi bekliyorum hocam

Ekli dosyayı kullanırsanız; çok hızlı (bir kaç saniye) çalışıyor bu kodlar...
umarım faydalı olur

 

[modoste]

gerçek malzeme listesini uyguladıktan sonra kriterleri bu şekilde belirledikten sonra çalıştırınca uyarı verdi bu hata nedir hocam

 

[modoste]

sayın Hocam 13 nolu mesajımda kullandığım dosya sizin 12 nolu dosyadır ve bunda hala 24 dakika 1440 saniye olan dosyadır bu hata bunda vermişti. (yani 13 nolu mesajımı dikkate almayın)
ben şimdi 10 nolu mesajdaki dosyaya bakıyorum gerçek verilerle denemeler yapıyorum bi sıkıntı çıkarsa yazacam

ilk sıkıntı makro çalışınca en az 10 saniyede çözüm buluyor. değişken durumlar için çözümler bulunuyor hatasız buluyor. (tek sıkıntı 10 saniyeye kadar süren süre)