Kod Kısaltma

[tamer42]

Merhaba,
Aşağıdaki kodda tabloda aylara göre plaka bilgilerini raporlamak istiyorum

eğer a (ay) değeri 0 olunca, ayları filtrelemeden tüm ayları alsın, a (ay) değeri 1,2,3 .... 11,12 olduğunda ilgili ayın verilerini getirsin diye aşağıdaki kodu oluşturdum.

bana göre biraz uzun bir kod oldu,

If Trim(wSh.Range("D" & x).Value) = plaka And Month(wSh.Range("B" & x).Value) = a Then

kod satırında a (ay) değeri 0 olduğunda "hepsini al" gibi bir yapılandırma yapılabilir mi? özetle amacım kodu kısaltmak...

ilginiz için şimdiden teşekkürler, iyi çalışmalar.

Sub Test
PlakaAra11, plaka, 0
end sub

Private Sub PlakaAra11(plaka As String, a As Byte)
Dim wSh As Worksheet
Dim st As String
Dim ara As String
Dim x As Long
Dim y As Byte
Dim ks As Integer

ks = 1

Set wSh = Sheets("Turlar")

For x = 2 To 100000

    If wSh.Range("A" & x) = "" Then Exit For
    
If a = 0 Then
     If Trim(wSh.Range("D" & x).Value) = plaka Then

    
            ks = ks + 1
            
            For y = 1 To 12
            
                Sayfa12.Cells(ks, y).Value = wSh.Cells(x, y).Value
            
            Next y
        
        End If
        
Else
       If Trim(wSh.Range("D" & x).Value) = plaka And Month(wSh.Range("B" & x).Value) = a Then
        
            ks = ks + 1
            
            For y = 1 To 12
            
                Sayfa12.Cells(ks, y).Value = wSh.Cells(x, y).Value
            
            Next y
        
        End If
    
End If

Next x

Set wSh = Nothing
End Sub

 

[Korhan Ayhan]

Örnek dosya paylaşır mısınız?

 

[tamer42]

Örnek dosya paylaşır mısınız?

Örnek dosya ekte sunulmuştur Korhan Hocam...

 

[Korhan Ayhan]

Deneyiniz.

Excelin filtre yöntemi kullanıldı. Daha hızlı işlem yapacaktır.

Option Explicit

Sub Filtrele()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim Plaka As String, Ay As Byte, Yil As Integer, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Giriş")
    Set S2 = Sheets("Turlar")
    Set S3 = Sheets("Sayfa2")
    
    S3.Cells.Clear
    
    Plaka = S1.Range("B1").Value
    Ay = S1.Range("B2").Value
    Yil = 2022
    
    With S2.Range("A1:H" & S1.Cells(S1.Rows.Count, 1).End(3).Row)
        .AutoFilter
        .AutoFilter 4, Plaka
         If Ay > 0 Then .AutoFilter 2, ">=" & CLng(CDate(DateSerial(Yil, Ay, 1))), xlAnd, _
                                       "<=" & CLng(CDate(DateSerial(Yil, Ay + 1, 0)))
         .CurrentRegion.Copy S3.Range("A1")
         .AutoFilter
    End With
    
    S3.Columns.AutoFit
    S3.Select
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[Korhan Ayhan]

Alternatif;

ADO...

Option Explicit

Sub Filtrele_Ado()
    Dim My_Connection As Object, My_Recordset As Object, Zaman As Double
    Dim S1 As Worksheet, S2 As Worksheet, Plaka As String, Ay As Byte
    
    Zaman = Timer
  
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Giriş")
    Set S2 = Sheets("Sayfa2")
    Set My_Connection = VBA.CreateObject("AdoDb.Connection")
 
    S2.Cells.Clear
    
    Plaka = S1.Range("B1").Value
    Ay = S1.Range("B2").Value
 
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
     
    Set My_Recordset = My_Connection.Execute("Select * From [Turlar$] Where F4 = '" & Plaka & "'" & IIf(Ay = 0, "", " And Month(F2) = " & Ay))
  
    Sheets("Turlar").Range("A1:H1").Copy S2.Range("A1")
    S2.Range("A2").CopyFromRecordset My_Recordset
    S2.Range("B2:C" & S2.Rows.Count).NumberFormat = "m/d/yyyy"
  
    If My_Recordset.State <> 0 Then My_Recordset.Close
    If My_Connection.State <> 0 Then My_Connection.Close
  
    S2.Columns.AutoFit
    S2.Select
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set My_Connection = Nothing
    Set My_Recordset = Nothing
  
    Application.ScreenUpdating = True
    
    MsgBox "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[tamer42]

Alternatif;

ADO...

Option Explicit

Sub Filtrele_Ado()
    Dim My_Connection As Object, My_Recordset As Object, Zaman As Double
    Dim S1 As Worksheet, S2 As Worksheet, Plaka As String, Ay As Byte
   
    Zaman = Timer
 
    Application.ScreenUpdating = False
   
    Set S1 = Sheets("Giriş")
    Set S2 = Sheets("Sayfa2")
    Set My_Connection = VBA.CreateObject("AdoDb.Connection")

    S2.Cells.Clear
   
    Plaka = S1.Range("B1").Value
    Ay = S1.Range("B2").Value

    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
    
    Set My_Recordset = My_Connection.Execute("Select * From [Turlar$] Where F4 = '" & Plaka & "'" & IIf(Ay = 0, "", " And Month(F2) = " & Ay))
 
    Sheets("Turlar").Range("A1:H1").Copy S2.Range("A1")
    S2.Range("A2").CopyFromRecordset My_Recordset
    S2.Range("B2:C" & S2.Rows.Count).NumberFormat = "m/d/yyyy"
 
    If My_Recordset.State <> 0 Then My_Recordset.Close
    If My_Connection.State <> 0 Then My_Connection.Close
 
    S2.Columns.AutoFit
    S2.Select
   
    Set S1 = Nothing
    Set S2 = Nothing
    Set My_Connection = Nothing
    Set My_Recordset = Nothing
 
    Application.ScreenUpdating = True
   
    MsgBox "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

çok teşekkürler Korhan Hocam