Soru Puantaj Verilerini Yatay Olarak Getirme

baykan_m · 23 Mart 2023

Merhaba Arkadaşlar,

Puantaj işlemi için programdan çektiğim verileri "TBHR" sekmesinde gösterdim. "TBHR" sekmesinde "H" sütununda olan verileri yatay olarak "PUANTAJ" sekmesine makro ile getirebilir miyiz? Ben 2 personel için örnek yaptım. O şekilde diğer tüm personelleri de getirebilirsek çok güzel olacak. İlgili dosya ektedir. Yardımcı olan arkadaşlara şimdiden teşekkür ederim.

dEdE · 23 Mart 2023

Merhaba,
Aşağıdaki kodları bir modüle yapıştırarak dener misiniz?
Yaklaşık 9 saniye çalışma süresi vardır.

C++:

Sub Aktar()
myTime = Timer
Set s1 = Sheets("PUANTAJ")
Set s2 = Sheets("TBHR")
ss = s1.Cells(Rows.Count, "A").End(3).Row
sat = 4: sut = 7
    myArr = s1.Range("A4:A" & ss)
    s1.Range("G4:AK" & ss).ClearContents
    Application.ScreenUpdating = False
    
    For i = LBound(myArr) To UBound(myArr)
        Set c = s2.Range("B:B").Find(myArr(i, 1), , xlValues, xlWhole)
        If Not c Is Nothing Then
            adres = c.Address
            Do
                s1.Cells(sat, sut) = s2.Cells(c.Row, 8).Value
                sut = sut + 1
            Set c = s2.Range("B:B").FindNext(c)
            Loop While Not c Is Nothing And c.Address <> adres
        End If
        sat = sat + 1
        sut = 7
    Next i
    Application.ScreenUpdating = True
 MsgBox "Görev  tamamlandı." & vbCrLf & "İşlem süresi: " & _
        Format(Timer - myTime, "0.00") & " Saniye", vbInformation, "BİLGİ"
End Sub

baykan_m · 24 Mart 2023

dEdE' Alıntı:

Merhaba,
Aşağıdaki kodları bir modüle yapıştırarak dener misiniz?
Yaklaşık 9 saniye çalışma süresi vardır.

C++:

Sub Aktar()
myTime = Timer
Set s1 = Sheets("PUANTAJ")
Set s2 = Sheets("TBHR")
ss = s1.Cells(Rows.Count, "A").End(3).Row
sat = 4: sut = 7
    myArr = s1.Range("A4:A" & ss)
    s1.Range("G4:AK" & ss).ClearContents
    Application.ScreenUpdating = False
   
    For i = LBound(myArr) To UBound(myArr)
        Set c = s2.Range("B:B").Find(myArr(i, 1), , xlValues, xlWhole)
        If Not c Is Nothing Then
            adres = c.Address
            Do
                s1.Cells(sat, sut) = s2.Cells(c.Row, 8).Value
                sut = sut + 1
            Set c = s2.Range("B:B").FindNext(c)
            Loop While Not c Is Nothing And c.Address <> adres
        End If
        sat = sat + 1
        sut = 7
    Next i
    Application.ScreenUpdating = True
MsgBox "Görev  tamamlandı." & vbCrLf & "İşlem süresi: " & _
        Format(Timer - myTime, "0.00") & " Saniye", vbInformation, "BİLGİ"
End Sub

Çok teşekkür ederim, elinize sağlık mükemmel olmuş.

Korhan Ayhan · 24 Mart 2023

Alternatif;

Süre olarak 1 tık daha avantaj sağlar.

C++:

Option Explicit

Sub Data_Transfer()
    Dim S1 As Worksheet, S2 As Worksheet, Process_Time As Double
    Dim Last_Row_1 As Long, Last_Row_2 As Long, My_Formula As String
    
    Process_Time = Timer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("PUANTAJ")
    Set S2 = Sheets("TBHR")
    
    Last_Row_1 = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Last_Row_2 = S2.Cells(S2.Rows.Count, 2).End(3).Row
    My_Formula = "=IFERROR(INDEX(TBHR!$H$1:$H$1048576,AGGREGATE(15,6,ROW(TBHR!$H$1:$H$1048576)/(TBHR!$B$1:$B$1048576=$A4),COLUMN(A$1))),"""")"
    My_Formula = Replace(My_Formula, 1048576, Last_Row_2)
    
    S1.Range("G4:AK" & Last_Row_1).Formula = My_Formula
    S1.Range("G4:AK" & Last_Row_1).Value = S1.Range("G4:AK" & Last_Row_1).Value

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
End Sub

dEdE · 24 Mart 2023

@Korhan Ayhan Üstadım,
#2 numaralı mesajdaki kodun Do.... ..Loop döngü arasındaki hücrelere yazdırma işlemi yerine, hızı artırmak amacıyla verileri diziye alıp, topluca satırlara yazdırmak istedim. Ancak diziye aldığım saat formatındaki verileri satırlara yazdırırken saat formatında yazdıramadım. Yazdırma öncesinde ve sonrasında yaptığım biçimlendirme işlemi başarısız oldu.

Diziye alınmış saat formatındaki verileri, yine aynı formatta toplu olarak yazdırmak(Resize ile) mümkün müdür?

Teşekkürler.

Korhan Ayhan · 24 Mart 2023

Diziyle tasarladığınız kodu paylaşın deneme yapalım.

dEdE · 24 Mart 2023

Korhan Ayhan' Alıntı:
Diziyle tasarladığınız kodu paylaşın deneme yapalım.

Hız için düşünmüştüm ama hem yeterince hızlı olmadı, hem de saat formatında sorun çıkardı.

C++:

Sub Aktar()
Dim Dizi(31) As String
Set S1 = Sheets("PUANTAJ")
Set S2 = Sheets("TBHR")
ss = S1.Cells(Rows.Count, "A").End(3).Row
sat = 4
    myArr = S1.Range("A4:A" & ss)
    S1.Range("G4:AK" & ss).ClearContents
    
    For i = LBound(myArr) To UBound(myArr)
        x = 0
        Set c = S2.Range("B:B").Find(myArr(i, 1), , xlValues, xlWhole)
        If Not c Is Nothing Then
            adres = c.Address
            Do
                Dizi(x) = S2.Cells(c.Row, 8).Value
                x = x + 1
            Set c = S2.Range("B:B").FindNext(c)
            Loop While Not c Is Nothing And c.Address <> adres
        End If
            S1.Range("G" & sat).Resize(, UBound(Dizi)) = Dizi
            sat = sat + 1
    Next i
End Sub

Korhan Ayhan · 24 Mart 2023

@dEdE,

Hız istiyorsanız hem hedefi hem de kaynağı dizi ile işleme almanız gerekir. Aksi durumda hücreleri kullandığınız vakit beklediğiniz performansı alamazsınız.

Korhan Ayhan · 24 Mart 2023

Ek olarak verilerin yazılacağı alan zaten Saat şeklinde biçimlendirilmiş. Bu sebeple ekstra bir işleme gerek olmaması gerekir.

Şimdi dizi yöntemiyle bir uygulama denedim. İşlem yaklaşık 0,10 saniye civarında tamamlanıyor. Denemek istersiniz diye aşağıda paylaşıyorum.

C++:

Option Explicit

Sub Data_Transfer()
    Dim S1 As Worksheet, S2 As Worksheet, My_Array As Object, Process_Time As Double
    Dim My_Data As Variant, X As Long, Y As Integer, Row_No As Long, Data_Key As Variant
 
    Process_Time = Timer
 
    Application.ScreenUpdating = False
 
    Set S1 = Sheets("PUANTAJ")
    Set S2 = Sheets("TBHR")
    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
 
    My_Data = S2.Range("A6:L" & S2.Cells(S2.Rows.Count, 2).End(3).Row).Value
 
    ReDim My_List(1 To UBound(My_Data, 1), 1 To 31)
 
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        If My_Data(X, 2) <> "" Then
            If Not My_Array.Exists(My_Data(X, 2)) Then
                Row_No = Row_No + 1
                My_Array.Add My_Data(X, 2), Array(Row_No, 1)
                My_List(Row_No, 1) = My_Data(X, 8)
            Else
                Data_Key = My_Array.Item(My_Data(X, 2))
                Data_Key(1) = Data_Key(1) + 1
                My_List(Data_Key(0), Data_Key(1)) = My_Data(X, 8)
                My_Array.Item(My_Data(X, 2)) = Data_Key
            End If
        End If
    Next

    My_Data = S1.Range("A4:AK" & S1.Cells(S1.Rows.Count, 1).End(3).Row).Value
 
    ReDim My_Report(1 To UBound(My_Data), 1 To 31)
 
    Row_No = 0
 
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        Row_No = Row_No + 1
        If My_Data(X, 1) <> "" Then
            If My_Array.Exists(My_Data(X, 1)) Then
                For Y = 1 To 31
                    My_Report(Row_No, Y) = My_List(My_Array.Item(My_Data(X, 1))(0), Y)
                Next
            End If
        End If
    Next

    S1.Range("G4:AK" & S1.Rows.Count).ClearContents
    S1.Range("G4").Resize(Row_No, UBound(My_Report, 2)) = My_Report

    Erase My_Data
    Erase My_List
    Erase My_Report
    My_Array.RemoveAll

    Set S1 = Nothing
    Set S2 = Nothing
    Set My_Array = Nothing

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
End Sub

dEdE · 24 Mart 2023

Teşekkürler.
Diziler konusuna çalışmam gerek. Benim için öğretici oldu.

Soru Puantaj Verilerini Yatay Olarak Getirme

baykan_m

Ekli dosyalar

dEdE

Destek Ekibi

baykan_m

Korhan Ayhan

Administrator

dEdE

Destek Ekibi

Korhan Ayhan

Administrator

dEdE

Destek Ekibi

Korhan Ayhan

Administrator

Korhan Ayhan

Administrator

dEdE

Destek Ekibi