veri aktarma

metin_0606 · 15 Ekim 2019

Makro Veri isimli sayfaya girdiğim verileri TC kimlik no ve çalışma durumu etkin olanları baz alarak süzüyor ve ANA SAYFA isimli sayfamda ilgili TC kimlik numarasının karşılığına bilgileri aktarıyor. Yalnız bunu veri sayısı çok olunca 3-4 dakikada yapıyor. Bu süreyi kısaltablirmiyiz acaba

kulomer46 · 15 Ekim 2019

Değerli Arkadaşım

Benden daha önce sizin için yazdığım programı geliştirmemi ve işlem süresini kısaltmamı istemiştiniz.
Ben de program üzerinde biraz daha emek vererek çalıştım ve kodları geliştirdim.
Program artık son haliyle 10.000 satırlık veriyi yaklaşık olarak 1,5 dakikada dağıtabilmektedir.

Programın son hali size ulaşmamış olabilir diye burayada ekliyorum.

Selamlar...

metin_0606 · 15 Ekim 2019

kulomer46' Alıntı:
Değerli Arkadaşım

Benden daha önce sizin için yazdığım programı geliştirmemi ve işlem süresini kısaltmamı istemiştiniz.
Ben de program üzerinde biraz daha emek vererek çalıştım ve kodları geliştirdim.
Program artık son haliyle 10.000 satırlık veriyi yaklaşık olarak 1,5 dakikada dağıtabilmektedir.

Programın son hali size ulaşmamış olabilir diye burayada ekliyorum.

Selamlar...

Tşkler hocam paylaşımınız için bir numaradaki paylasimim için yardımcı olabilirmisiniz

kulomer46 · 15 Ekim 2019

metin_0606' Alıntı:
Tşkler hocam paylaşımınız için bir numaradaki paylasimim için yardımcı olabilirmisiniz

Merhaba

Bir numaralı mesajınızdaki talebinizi anlamadım. Talebinizi örnekli olarak tam açıklamalı yazarsanız yardımcı olabilirim.

Selamlar...

metin_0606 · 15 Ekim 2019

kulomer46' Alıntı:
Merhaba

Bir numaralı mesajınızdaki talebinizi anlamadım. Talebinizi örnekli olarak tam açıklamalı yazarsanız yardımcı olabilirim.

Selamlar...

Hocam bir nolu mesajda sayfalara verileri yükledim örnek dosyayi makrosu ile paylaştım makro veri sayfasindaki girilen bilgileri ana sayfa isimli sayfama aktarıyor. Ancak veri sayısı çok olunca makro çok yavaş çalışıyor

muhsar · 15 Ekim 2019

kulomer46' Alıntı:
Değerli Arkadaşım

Benden daha önce sizin için yazdığım programı geliştirmemi ve işlem süresini kısaltmamı istemiştiniz.
Ben de program üzerinde biraz daha emek vererek çalıştım ve kodları geliştirdim.
Program artık son haliyle 10.000 satırlık veriyi yaklaşık olarak 1,5 dakikada dağıtabilmektedir.

Programın son hali size ulaşmamış olabilir diye burayada ekliyorum.

Selamlar...

sn hocam;bu çalışmayı kendi çalışmama uyarlamak için çok uğraştım başaramıyorum birtürlü
rica etsem kod yerleştirme bölümünü göstereilirmisiniz

son sütun adı:AT

sütun sayısı 46

8.sütuna göre gruplama yapacaK

h sütunu

veri sayısı 3500

metin_0606 · 15 Ekim 2019

Güncel

Ziynettin · 15 Ekim 2019

Kod:

Sub AKTAR()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("ANA SAYFA")
Set s2 = Sheets("VERİ")
Set dc = CreateObject("scripting.dictionary")
tm = TimeValue(Now)
a = s2.Range("A2:H" & s2.Cells(Rows.Count, 1).End(xlUp).Row).Value
For i = 1 To UBound(a)
dc(CStr(a(i, 1))) = i
Next i
b = s1.Range("B2:Z" & s1.Cells(Rows.Count, 3).End(xlUp).Row).Value
ReDim w(1 To UBound(b), 1 To UBound(b, 2))
For i = 1 To UBound(b)
    For j = 1 To UBound(b, 2)
        w(i, j) = b(i, j)
    Next j
    If b(i, 23) = "Etkin" Then
        deg = CStr(b(i, 2))
        If dc.exists(deg) Then
            n = dc(deg)
            w(i, 1) = a(n, 2)
            w(i, 4) = a(n, 3)
            w(i, 8) = a(n, 4)
            w(i, 20) = a(n, 5)
            w(i, 25) = a(n, 6)
            w(i, 12) = a(n, 7)
        End If
    End If
Next i
s1.[B2].Resize(UBound(b), UBound(b, 2)) = w

MsgBox "İşlem tamam." & vbLf & vbLf & CDate(TimeValue(Now) - tm), vbInformation
End Sub

muhsar · 15 Ekim 2019

kulomer46' Alıntı:
Merhaba

Bir numaralı mesajınızdaki talebinizi anlamadım. Talebinizi örnekli olarak tam açıklamalı yazarsanız yardımcı olabilirim.

Selamlar...

sn hocam bu konu çok arkadaşın dikkatini çekiyor,rica etsek kendimize uyarlamak için kodda değişmesi gerekenleri yazsanız olmazmı,gruplama yapacak kolon için şu kısımlar;listeniz başlangıç ve son kolon satırının yazılacağı alan gibi..çok teşekkür ediyorum şimdiden emekleriniz için

metin_0606 · 16 Ekim 2019

Ziynettin' Alıntı:

Kod:

Sub AKTAR()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("ANA SAYFA")
Set s2 = Sheets("VERİ")
Set dc = CreateObject("scripting.dictionary")
tm = TimeValue(Now)
a = s2.Range("A2:H" & s2.Cells(Rows.Count, 1).End(xlUp).Row).Value
For i = 1 To UBound(a)
dc(CStr(a(i, 1))) = i
Next i
b = s1.Range("B2:Z" & s1.Cells(Rows.Count, 3).End(xlUp).Row).Value
ReDim w(1 To UBound(b), 1 To UBound(b, 2))
For i = 1 To UBound(b)
    For j = 1 To UBound(b, 2)
        w(i, j) = b(i, j)
    Next j
    If b(i, 23) = "Etkin" Then
        deg = CStr(b(i, 2))
        If dc.exists(deg) Then
            n = dc(deg)
            w(i, 1) = a(n, 2)
            w(i, 4) = a(n, 3)
            w(i, 8) = a(n, 4)
            w(i, 20) = a(n, 5)
            w(i, 25) = a(n, 6)
            w(i, 12) = a(n, 7)
        End If
    End If
Next i
s1.[B2].Resize(UBound(b), UBound(b, 2)) = w

MsgBox "İşlem tamam." & vbLf & vbLf & CDate(TimeValue(Now) - tm), vbInformation
End Sub

Ziynettin hocam süper çalışıyor çok teşekkür ederim

metin_0606 · 16 Ekim 2019

Ziynettin' Alıntı:

Kod:

Sub AKTAR()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("ANA SAYFA")
Set s2 = Sheets("VERİ")
Set dc = CreateObject("scripting.dictionary")
tm = TimeValue(Now)
a = s2.Range("A2:H" & s2.Cells(Rows.Count, 1).End(xlUp).Row).Value
For i = 1 To UBound(a)
dc(CStr(a(i, 1))) = i
Next i
b = s1.Range("B2:Z" & s1.Cells(Rows.Count, 3).End(xlUp).Row).Value
ReDim w(1 To UBound(b), 1 To UBound(b, 2))
For i = 1 To UBound(b)
    For j = 1 To UBound(b, 2)
        w(i, j) = b(i, j)
    Next j
    If b(i, 23) = "Etkin" Then
        deg = CStr(b(i, 2))
        If dc.exists(deg) Then
            n = dc(deg)
            w(i, 1) = a(n, 2)
            w(i, 4) = a(n, 3)
            w(i, 8) = a(n, 4)
            w(i, 20) = a(n, 5)
            w(i, 25) = a(n, 6)
            w(i, 12) = a(n, 7)
        End If
    End If
Next i
s1.[B2].Resize(UBound(b), UBound(b, 2)) = w

MsgBox "İşlem tamam." & vbLf & vbLf & CDate(TimeValue(Now) - tm), vbInformation
End Sub

Ziynettin hocam verileri aktardığı hücrede formül olmamasına rağmen verileri aktardığı sayfadaki formülleri siliyor neden acaba

Ziynettin' Alıntı:

Kod:

Sub AKTAR()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("ANA SAYFA")
Set s2 = Sheets("VERİ")
Set dc = CreateObject("scripting.dictionary")
tm = TimeValue(Now)
a = s2.Range("A2:H" & s2.Cells(Rows.Count, 1).End(xlUp).Row).Value
For i = 1 To UBound(a)
dc(CStr(a(i, 1))) = i
Next i
b = s1.Range("B2:Z" & s1.Cells(Rows.Count, 3).End(xlUp).Row).Value
ReDim w(1 To UBound(b), 1 To UBound(b, 2))
For i = 1 To UBound(b)
    For j = 1 To UBound(b, 2)
        w(i, j) = b(i, j)
    Next j
    If b(i, 23) = "Etkin" Then
        deg = CStr(b(i, 2))
        If dc.exists(deg) Then
            n = dc(deg)
            w(i, 1) = a(n, 2)
            w(i, 4) = a(n, 3)
            w(i, 8) = a(n, 4)
            w(i, 20) = a(n, 5)
            w(i, 25) = a(n, 6)
            w(i, 12) = a(n, 7)
        End If
    End If
Next i
s1.[B2].Resize(UBound(b), UBound(b, 2)) = w

MsgBox "İşlem tamam." & vbLf & vbLf & CDate(TimeValue(Now) - tm), vbInformation
End Sub

Ziynettin hocam verileri aktardığı hücrede formül olmamasına rağmen aktardığı sayfadaki formülleri siliyor neden acaba

kulomer46 · 16 Ekim 2019

muhsar' Alıntı:
sn hocam bu konu çok arkadaşın dikkatini çekiyor,rica etsek kendimize uyarlamak için kodda değişmesi gerekenleri yazsanız olmazmı,gruplama yapacak kolon için şu kısımlar;listeniz başlangıç ve son kolon satırının yazılacağı alan gibi..çok teşekkür ediyorum şimdiden emekleriniz için

Değerli Arkadaşım

Talebinizi aldım.
Ek' teki dosyada gruplamak istenilen sütuna, toplam kaç sütun için işlem yapılacak bunlara kullanıcı karar veriyor.
Böylece program daha esnek oldu.

Selamlar...

muhsar · 16 Ekim 2019

kulomer46' Alıntı:
Değerli Arkadaşım

Talebinizi aldım.
Ek' teki dosyada gruplamak istenilen sütuna, toplam kaç sütun için işlem yapılacak bunlara kullanıcı karar veriyor.
Böylece program daha esnek oldu.

Selamlar...

Range("A2:Y" & soncc).ClearContents

hocam bu satırı gösterir hata verdi kolan sayısı 46 gruplama 13 yaptım kendi çalışmama göre

kulomer46 · 16 Ekim 2019

muhsar' Alıntı:
Range("A2:Y" & soncc).ClearContents

hocam bu satırı gösterir hata verdi kolan sayısı 46 gruplama 13 yaptım kendi çalışmama göre

Merhaba Programda,

Kod:

Range("A2:Y" & soncc).ClearContents

kodunu silip yerine

Kod:

Range(Cells(2, 1), Cells(soncc, 255)).ClearContents

Kodunu ekledim.

Düzeltmenin yapılmış şekliyle dosyanın son hali Ek' tedir.

Problemin giderilmiş olması lazım. Deneyiniz. Selamlar...

muhsar · 16 Ekim 2019

kulomer46' Alıntı:
Merhaba Programda,

Kod:

Range("A2:Y" & soncc).ClearContents

kodunu silip yerine

Kod:

Range(Cells(2, 1), Cells(soncc, 255)).ClearContents

Kodunu ekledim.

Düzeltmenin yapılmış şekliyle dosyanın son hali Ek' tedir.

Problemin giderilmiş olması lazım. Deneyiniz. Selamlar...

HOCAM MAKRO3 son gönderilen makro mesela 13 nolu sütunu sıralamak istedim

kulomer46 · 16 Ekim 2019

muhsar' Alıntı:
HOCAM MAKRO3 son gönderilen makro mesela 13 nolu sütunu sıralamak istedim

Değerli Arkadaşım

Bugün öğleden sonra yaklaşık 3 saatten fazla uğraşı ve birçok deneme sonucu dosyanız isteğinize uygun hale geldi.

Dosyanız Ek' tedir.

Selamlar...

muhsar · 16 Ekim 2019

kulomer46' Alıntı:
Değerli Arkadaşım

Bugün öğleden sonra yaklaşık 3 saatten fazla uğraşı ve birçok deneme sonucu dosyanız isteğinize uygun hale geldi.

Dosyanız Ek' tedir.

Selamlar...

çok teşekkür ederim,hakkınızı helal edin ,çok güzel bir çalışma olmuş ,elinize sağlık tekrar teşekkür ederim

kulomer46 · 16 Ekim 2019

muhsar' Alıntı:
çok teşekkür ederim,hakkınızı helal edin ,çok güzel bir çalışma olmuş ,elinize sağlık tekrar teşekkür ederim

Merhaba

İşte bu yeter. İşe yaraması, faydalı olması, hayırlı bir dua ...

Selamlar...

metin_0606 · 16 Ekim 2019

Ziynettin' Alıntı:

Kod:

Sub AKTAR()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("ANA SAYFA")
Set s2 = Sheets("VERİ")
Set dc = CreateObject("scripting.dictionary")
tm = TimeValue(Now)
a = s2.Range("A2:H" & s2.Cells(Rows.Count, 1).End(xlUp).Row).Value
For i = 1 To UBound(a)
dc(CStr(a(i, 1))) = i
Next i
b = s1.Range("B2:Z" & s1.Cells(Rows.Count, 3).End(xlUp).Row).Value
ReDim w(1 To UBound(b), 1 To UBound(b, 2))
For i = 1 To UBound(b)
    For j = 1 To UBound(b, 2)
        w(i, j) = b(i, j)
    Next j
    If b(i, 23) = "Etkin" Then
        deg = CStr(b(i, 2))
        If dc.exists(deg) Then
            n = dc(deg)
            w(i, 1) = a(n, 2)
            w(i, 4) = a(n, 3)
            w(i, 8) = a(n, 4)
            w(i, 20) = a(n, 5)
            w(i, 25) = a(n, 6)
            w(i, 12) = a(n, 7)
        End If
    End If
Next i
s1.[B2].Resize(UBound(b), UBound(b, 2)) = w

MsgBox "İşlem tamam." & vbLf & vbLf & CDate(TimeValue(Now) - tm), vbInformation
End Sub

Ziynettin hocam paylaştığıniz kod ile bu gün 200 kişilik toplu veri girdisi yaptım. Süre olarak çok çabuk bir aktarım yaptı. Ancak verileri aktardığı sayfadaki hücrede formül olmamasına rağmen formülleri sildi. Ayrıca verileri aktardığı sayfadaki bazı verilerde değişiklik yapmaması gerektiği halde verileri değiştirdi. Örneğin kiminin TC sinin karşılığına başka personelin ismini getirmiş başkasının görev unvanını başkasına aktarmış yani kısacası aktardigim verilerle ilgisi olmayan verilerde de değişiklik yapmış bunu nasıl düzeltebiliriz

metin_0606 · 17 Ekim 2019

Güncel

veri aktarma

metin_0606

Ekli dosyalar

kulomer46

Ekli dosyalar

metin_0606

kulomer46

metin_0606

muhsar

metin_0606

Ziynettin

Destek Ekibi

muhsar

metin_0606

metin_0606

kulomer46

Ekli dosyalar

muhsar

kulomer46

Ekli dosyalar

muhsar

Ekli dosyalar

kulomer46

Ekli dosyalar

muhsar

kulomer46

metin_0606

metin_0606