şartlı makro

[agunes4242]

Veri sayfasına girdiğim tarih aralığı kadar liste sayfasına yazdığım sebepleri işlemek. ayrıca bir şahıssa birden fazla veri girildiğinde liste sayfasında tek satıda veri girişi yapılacak ayrı bir satır açmayacak bu şekil bir makro yazabiliriz acaba. veri girişi yapılmayan hücreler (x) olacak son sütuna (x) lerin sayısını toplatacağız.

 

[hasankardas]

Sub aktar()
    Dim veriWS As Worksheet, listeWS As Worksheet
    Dim veriLastRow As Long, listeLastRow As Long
    Dim i As Long, j As Long
    Dim startDate As Date, endDate As Date
    Dim kod As String, ad As String, soyad As String, grup As String
    Dim kodlarDict As Object
    
    ' Sözlük nesnesini oluştur
    Set kodlarDict = CreateObject("Scripting.Dictionary")
    
    ' Sayfaları tanımlayın
    Set veriWS = ThisWorkbook.Sheets("veri")
    Set listeWS = ThisWorkbook.Sheets("liste")
    
    ' veri sayfasındaki son satırı bulun
    veriLastRow = veriWS.Cells(veriWS.Rows.Count, "B").End(xlUp).Row
    
    ' liste sayfasındaki kodları kopyalayın
    listeLastRow = listeWS.Cells(listeWS.Rows.Count, "B").End(xlUp).Row
    If listeLastRow > 1 Then listeWS.Range("B2:B" & listeLastRow).ClearContents
    
    ' Benzersiz kodları ve ilgili bilgileri liste sayfasına kopyalayın
    Dim rowCounter As Long
    rowCounter = 2 ' Liste sayfasında B sütunu, 2. satırdan başlamalı
    
    For i = 2 To veriLastRow
        kod = veriWS.Cells(i, "B").Value
        ad = veriWS.Cells(i, "C").Value
        soyad = veriWS.Cells(i, "D").Value
        grup = veriWS.Cells(i, "F").Value
        If Not kodlarDict.exists(kod) Then
            kodlarDict.Add kod, rowCounter
            listeWS.Cells(rowCounter, "B").Value = kod
            listeWS.Cells(rowCounter, "C").Value = ad
            listeWS.Cells(rowCounter, "D").Value = soyad
            listeWS.Cells(rowCounter, "F").Value = grup
            rowCounter = rowCounter + 1
        End If
    Next i
    
    ' liste sayfasındaki tarih aralığı
    Set dateRange = listeWS.Range("G1:AK1")
    
    ' veri sayfasındaki her bir satırı kontrol edin
    For i = 2 To veriLastRow
        startDate = veriWS.Cells(i, "G").Value
        endDate = veriWS.Cells(i, "H").Value
        reason = veriWS.Cells(i, "I").Value
        kod = veriWS.Cells(i, "B").Value
        
        ' Başlangıç ve bitiş tarih aralığındaki her tarih için
        For j = 1 To dateRange.Columns.Count
            If dateRange.Cells(1, j).Value >= startDate And dateRange.Cells(1, j).Value <= endDate Then
                If kodlarDict.exists(kod) Then
                    listeWS.Cells(kodlarDict(kod), j + 6).Value = reason
                End If
            ElseIf listeWS.Cells(kodlarDict(kod), j + 6).Value = "" Then
                listeWS.Cells(kodlarDict(kod), j + 6).Value = "x"
            End If
        Next j
    Next i
    
    ' AL sütunundaki x sayısını aynı satırda yaz
    For i = 2 To rowCounter - 1
        listeWS.Cells(i, "AL").Value = Application.WorksheetFunction.CountIf(listeWS.Range(listeWS.Cells(i, "G"), listeWS.Cells(i, "AK")), "x")
    Next i
    
    ' İşlemin başarılı olduğunu bildirin
    MsgBox "İşlem tamamlandı!", vbInformation

End Sub

 

[agunes4242]

TEŞEKKÜR EDERİM ELLERİNİZE SAĞLIK TAM OLARAK ÇALIŞTI.