• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Soru Puantaj Verilerini Yatay Olarak Getirme

B

baykan_m

Altın Üye
Katılım
26 Ağustos 2015
Mesajlar
257
Excel Vers. ve Dili
Office 365
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.
 

Ekli dosyalar

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
 
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
Genişletmek için tıkla ...
Çok teşekkür ederim, elinize sağlık mükemmel olmuş.
 
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
 
@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.
 
Diziyle tasarladığınız kodu paylaşın deneme yapalım.
 
Korhan Ayhan' Alıntı:
Diziyle tasarladığınız kodu paylaşın deneme yapalım.
Genişletmek için tıkla ...

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
 
@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.
 
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
 
Teşekkürler.
Diziler konusuna çalışmam gerek. Benim için öğretici oldu.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst