• DİKKAT

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

Çoklu Düşeyara

H

hilmitaranci

Katılım
14 Haziran 2007
Mesajlar
142
Excel Vers. ve Dili
2007
Merhabalar,

Ekli örnek dosyamda ASCII sayfasındaki verileri TOPLA.ÇARPIM yardımıyla sayfa1 e almayı başardım. Ancak yaklaşık 1.500 çalışan olduğu için sistemim sürekli kitleniyor.

Bunu makro yada daha kolay bir yolla yapma şansım var mı?

Teşekkür ederim.


http://dosya.co/rpcn56f9pb5l/ornek.xls.html
 
Merhaba.

Formüllerinizi hızlandırma yöntemiyle ilgili bir önerim olacak.

Formüllerinizde tüm satırları kulanmanız satır belgenizin yavaş çalışmasına neden olur.
Bunun çözümü için; AD TANIMLAMASI kullanabilirsiniz veya formül ile son dolu satır numarasını tespit ettirerek,
arama/sayma gibi işlemlerin yapıldığı alanları daraltmalısınız.

Örneğin B3 hücresindeki aşağıdaki ilk formül yerine ikinci formül gibi bir yapı kullanırsanız belgeniz hızlanır.
İkinci formülde arama işlemi sütundaki tüm satırlarda değil sadece dolu satırlarda yapılır.
Bunu sağlayan DOLAYLI işlevi parantezi içerisindeki KAÇINCI işlevidir.
KAÇINCI işlevi kısmını başka bir hücreye uygularsanız sonuç 41'dir ve artık arama 65536 satırda değil 41 satırda yapılır.

NOT: Diğer formüllerinizi de buna göre düzenleyerek belgenize hız kazandırabilirsiniz.
.
Kod: 
=DÜŞEYARA(A3;ASCII![COLOR="Red"][B]B:E[/B][/COLOR];4;YANLIŞ)
=DÜŞEYARA($A3;DOLAYLI("ASCII![B][COLOR="Red"]B1:E[/COLOR][/B]"&[COLOR="Blue"]KAÇINCI("ZZZ";ASCII!$B:$B;1)[/COLOR]);4;YANLIŞ)
 
Ömer BARAN' Alıntı:
Merhaba.

Formüllerinizi hızlandırma yöntemiyle ilgili bir önerim olacak.

Formüllerinizde tüm satırları kulanmanız satır belgenizin yavaş çalışmasına neden olur.
Bunun çözümü için; AD TANIMLAMASI kullanabilirsiniz veya formül ile son dolu satır numarasını tespit ettirerek,
arama/sayma gibi işlemlerin yapıldığı alanları daraltmalısınız.

Örneğin B3 hücresindeki aşağıdaki ilk formül yerine ikinci formül gibi bir yapı kullanırsanız belgeniz hızlanır.
İkinci formülde arama işlemi sütundaki tüm satırlarda değil sadece dolu satırlarda yapılır.
Bunu sağlayan DOLAYLI işlevi parantezi içerisindeki KAÇINCI işlevidir.
KAÇINCI işlevi kısmını başka bir hücreye uygularsanız sonuç 41'dir ve artık arama 65536 satırda değil 41 satırda yapılır.

NOT: Diğer formüllerinizi de buna göre düzenleyerek belgenize hız kazandırabilirsiniz.
.
Kod: 
=DÜŞEYARA(A3;ASCII![COLOR="Red"][B]B:E[/B][/COLOR];4;YANLIŞ)
=DÜŞEYARA($A3;DOLAYLI("ASCII![B][COLOR="Red"]B1:E[/COLOR][/B]"&[COLOR="Blue"]KAÇINCI("ZZZ";ASCII!$B:$B;1)[/COLOR]);4;YANLIŞ)
Genişletmek için tıkla ...

Yanıtınız için çok teşekkür ederim.
Düşeyara ile yapmaya çalıştığımda ikinci koşullu kullanamadığım için sonuç maalesef istediğim gibi olmuyor. Bu nedenle düşeyarayı kullanmamıştım.
 
Merhaba,

Makro ile.

Kod: 
Sub tablo()
Set sh = Sheets("Sayfa1")
Set sh1 = Sheets("ASCII")
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set D3 = CreateObject("scripting.dictionary")
Z = TimeValue(Now)
Application.ScreenUpdating = False
sh.Cells.ClearContents
a = sh1.Range("A1:S" & sh1.Cells(Rows.Count, 1).End(3).Row)
ReDim h(1 To UBound(a), 1 To 3)
ReDim h1(1 To UBound(a), 1 To 3)

For i = 2 To UBound(a)
    If Not d1.exists(a(i, 2)) Then
        d1(a(i, 2)) = d2.Count + 1: m = d1.Count
        h1(m, 1) = a(i, 2): h1(m, 2) = a(i, 5): h1(m, 3) = a(i, 3)
    End If
    d2(a(i, 5)) = ""
    krt = a(i, 2) & a(i, 5): D3(krt) = D3.Count + 1: n = D3.Count
    h(n, 1) = a(i, 6): h(n, 2) = a(i, 8): h(n, 3) = a(i, 19)
Next i

sh.[B2] = "Giriş Tarihi": sh.[C2] = "Departman"
sh.[A3].Resize(d1.Count, 3) = h1

sut = 4
For Each v In d2.keys
    sh.Cells(1, sut) = v: sh.Cells(2, sut) = "Giriş"
    sh.Cells(2, sut + 1) = "Çıkış": sh.Cells(2, sut + 2) = "Açıklama"
    sut = sut + 3
Next v
sutun = sut - 4
On Error Resume Next
b = sh.Range("A1").Resize(d1.Count + 2, sut - 1)
ReDim c(1 To 10, 1 To sutun)
    For i = 3 To UBound(b)
        say = say + 1
        For j = 4 To UBound(b, 2) Step 3
            krt = b(i, 1) & b(1, j)
            c(say, j - 3) = h(D3(krt), 1)
            c(say, j + 1 - 3) = h(D3(krt), 2)
            c(say, j + 2 - 3) = h(D3(krt), 3)
        Next j
    Next i
sh.[D3].Resize(say, sutun) = c
sh.Select
Application.ScreenUpdating = True
MsgBox "İşlem tamam." & vbLf & vbLf & "    " & CDate(TimeValue(Now) - Z), vbInformation
End Sub
 

Ekli dosyalar

Son düzenleme:
Ziynettin' Alıntı:
Merhaba,

Makro ile.

Kod: 
Sub tablo()
Set sh = Sheets("Sayfa1")
Set sh1 = Sheets("ASCII")
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set D3 = CreateObject("scripting.dictionary")
Z = TimeValue(Now)
Application.ScreenUpdating = False
sh.Cells.ClearContents
a = sh1.Range("A1:S" & sh1.Cells(Rows.Count, 1).End(3).Row)
ReDim h(1 To UBound(a), 1 To 2)
ReDim h1(1 To UBound(a), 1 To 3)

For i = 2 To UBound(a)
    If Not d1.exists(a(i, 2)) Then
        d1(a(i, 2)) = d2.Count + 1: m = d1.Count
        h1(m, 1) = a(i, 2): h1(m, 2) = a(i, 5): h1(m, 3) = a(i, 3)
    End If
    d2(a(i, 5)) = ""
    krt = a(i, 2) & a(i, 5): D3(krt) = D3.Count + 1: n = D3.Count
    h(n, 1) = a(i, 6): h(n, 2) = a(i, 8)
Next i

sh.[B2] = "Giriş Tarihi": sh.[C2] = "Departman"
sh.[A3].Resize(d1.Count, 3) = h1

sut = 4
For Each v In d2.keys
    sh.Cells(1, sut) = v: sh.Cells(2, sut) = "Giriş"
    sh.Cells(2, sut + 1) = "Çıkış": sh.Cells(2, sut + 2) = "Açıklama"
    sut = sut + 3
Next v
sutun = sut - 4
On Error Resume Next
b = sh.Range("A1").Resize(d1.Count + 2, sut - 1)
ReDim c(1 To 10, 1 To sutun)
    For i = 3 To UBound(b)
        say = say + 1
        For j = 4 To UBound(b, 2) Step 3
            krt = b(i, 1) & b(1, j)
            c(say, j - 3) = h(D3(krt), 1)
            c(say, j + 1 - 3) = h(D3(krt), 2)
        Next j
    Next i
sh.[D3].Resize(say, sutun) = c
sh.Select
Application.ScreenUpdating = True
MsgBox "İşlem tamam." & vbLf & vbLf & CDate(TimeValue(Now) - Z), vbInformation
End Sub
Genişletmek için tıkla ...

Çok teşekkür ederim üstadım, sağolun.
 
Ziynettin' Alıntı:
Merhaba,

Makro ile.

Kod: 
Sub tablo()
Set sh = Sheets("Sayfa1")
Set sh1 = Sheets("ASCII")
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set D3 = CreateObject("scripting.dictionary")
Z = TimeValue(Now)
Application.ScreenUpdating = False
sh.Cells.ClearContents
a = sh1.Range("A1:S" & sh1.Cells(Rows.Count, 1).End(3).Row)
ReDim h(1 To UBound(a), 1 To 2)
ReDim h1(1 To UBound(a), 1 To 3)

For i = 2 To UBound(a)
    If Not d1.exists(a(i, 2)) Then
        d1(a(i, 2)) = d2.Count + 1: m = d1.Count
        h1(m, 1) = a(i, 2): h1(m, 2) = a(i, 5): h1(m, 3) = a(i, 3)
    End If
    d2(a(i, 5)) = ""
    krt = a(i, 2) & a(i, 5): D3(krt) = D3.Count + 1: n = D3.Count
    h(n, 1) = a(i, 6): h(n, 2) = a(i, 8)
Next i

sh.[B2] = "Giriş Tarihi": sh.[C2] = "Departman"
sh.[A3].Resize(d1.Count, 3) = h1

sut = 4
For Each v In d2.keys
    sh.Cells(1, sut) = v: sh.Cells(2, sut) = "Giriş"
    sh.Cells(2, sut + 1) = "Çıkış": sh.Cells(2, sut + 2) = "Açıklama"
    sut = sut + 3
Next v
sutun = sut - 4
On Error Resume Next
b = sh.Range("A1").Resize(d1.Count + 2, sut - 1)
ReDim c(1 To 10, 1 To sutun)
    For i = 3 To UBound(b)
        say = say + 1
        For j = 4 To UBound(b, 2) Step 3
            krt = b(i, 1) & b(1, j)
            c(say, j - 3) = h(D3(krt), 1)
            c(say, j + 1 - 3) = h(D3(krt), 2)
        Next j
    Next i
sh.[D3].Resize(say, sutun) = c
sh.Select
Application.ScreenUpdating = True
MsgBox "İşlem tamam." & vbLf & vbLf & CDate(TimeValue(Now) - Z), vbInformation
End Sub
Genişletmek için tıkla ...

Hocam tekrardan bir soru sormak istiyorum.

Açıklama bölümünü listeye bir türlü getirtemedim. Bunu nasıl yapacağımı söyleyebilir misiniz?
 
Açıklamaları aktarmak için kod revize edildi. Sayfa1 deki koşullu biçimlendirmeyi kaldırdıktan sonra kodu çalıştırın.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst