• DİKKAT

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

Makro Hakkında Yardım

S

serkan.sevinc

Katılım
12 Şubat 2014
Mesajlar
223
Excel Vers. ve Dili
office2013
Merhaba,
Ekteki dosyada ENVANTER sayfası ve SİPARİŞLER sayfasındaki bilgiler DATA sayfasına formül olarak gitmektedir. Bu formun uzun bir dosya olması sebebiyle formüller yavaş çalışmaktadır. Bu da uzun bir süre olmaktadır.
İstediğim;
SİPARİŞLER sayfasındaki bilgilerin ve ENVANTER sayfasındaki bilgilerin makro ile DATA sayfasına gitmesidir.

Yardımcı olursanız çok sevinirim.
 

Ekli dosyalar

Merhaba,

Data sayfasındaki formüller temizlendi, veriler kod ile aktarılmaktadır.

Olumlu sonuç için önce siparis gönderi çalıştırın sonra envanteri gönderi çalıştırın.
 

Ekli dosyalar

Dim i As Long, sat As Long, say As Integer

Kod satırını bu şekilde uyarlayın.

Dim i As Long, sat As Long, say As Long
 
250 (bin) satır büyük tablo. Bu kadar satırda işleminiz ne kadar sürede sonuç alıyorsunuz. Aşağıdaki koda mesaj ekranına zaman sonucu eklendi.

Kod: 
Sub envanter()
Dim s1 As Worksheet, s2 As Worksheet
Dim a(), b(), d As Object
Dim i As Long, sat As Long, say As Integer
Application.Calculation = xlCalculationManual
Set s1 = Sheets("envanter")
Set s2 = Sheets("data")
Set d = CreateObject("scripting.dictionary")
Z = TimeValue(Now)
a = s1.Range("A2:L" & s1.Cells(Rows.Count, 1).End(3).Row).Value

    For i = 1 To UBound(a)
        krt = a(i, 1) & a(i, 12)
        d(krt) = a(i, 5)
    Next i

b = s2.Range("I3:T" & UBound(a) * 7).Value

ReDim c1(1 To UBound(b), 1 To 1)
ReDim c2(1 To UBound(b), 1 To 1)
ReDim c3(1 To UBound(b), 1 To 1)
ReDim c4(1 To UBound(b), 1 To 1)
    For i = 1 To UBound(b)
        sat = sat + 1
        If b(i, 1) = "" Then
            say = say + 1
            b(sat, 1) = b(sat - say, 1)
        Else
            b(sat, 1) = b(sat, 1)
        say = 0
        End If
        krt1 = b(i, 1) & b(i, 6)
        krt2 = b(i, 1) & b(i, 8)
        krt3 = b(i, 1) & b(i, 10)
        krt4 = b(i, 1) & b(i, 12)
        c1(i, 1) = CDbl(d(krt1))
        c2(i, 1) = CDbl(d(krt2))
        c3(i, 1) = CDbl(d(krt3))
        c4(i, 1) = CDbl(d(krt4))
    Next i
    
    s2.[M3].Resize(UBound(b)) = c1
    s2.[O3].Resize(UBound(b)) = c2
    s2.[Q3].Resize(UBound(b)) = c3
    s2.[s3].Resize(UBound(b)) = c4
    
Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamam." & vbLf & vbLf & _
        CDate(TimeValue(Now) - Z), vbInformation
End Sub
 
Ziynettin' Alıntı:
250 (bin) satır büyük tablo. Bu kadar satırda işleminiz ne kadar sürede sonuç alıyorsunuz. Aşağıdaki koda mesaj ekranına zaman sonucu eklendi.

Kod: 
Sub envanter()
Dim s1 As Worksheet, s2 As Worksheet
Dim a(), b(), d As Object
Dim i As Long, sat As Long, say As Integer
Application.Calculation = xlCalculationManual
Set s1 = Sheets("envanter")
Set s2 = Sheets("data")
Set d = CreateObject("scripting.dictionary")
Z = TimeValue(Now)
a = s1.Range("A2:L" & s1.Cells(Rows.Count, 1).End(3).Row).Value

    For i = 1 To UBound(a)
        krt = a(i, 1) & a(i, 12)
        d(krt) = a(i, 5)
    Next i

b = s2.Range("I3:T" & UBound(a) * 7).Value

ReDim c1(1 To UBound(b), 1 To 1)
ReDim c2(1 To UBound(b), 1 To 1)
ReDim c3(1 To UBound(b), 1 To 1)
ReDim c4(1 To UBound(b), 1 To 1)
    For i = 1 To UBound(b)
        sat = sat + 1
        If b(i, 1) = "" Then
            say = say + 1
            b(sat, 1) = b(sat - say, 1)
        Else
            b(sat, 1) = b(sat, 1)
        say = 0
        End If
        krt1 = b(i, 1) & b(i, 6)
        krt2 = b(i, 1) & b(i, 8)
        krt3 = b(i, 1) & b(i, 10)
        krt4 = b(i, 1) & b(i, 12)
        c1(i, 1) = CDbl(d(krt1))
        c2(i, 1) = CDbl(d(krt2))
        c3(i, 1) = CDbl(d(krt3))
        c4(i, 1) = CDbl(d(krt4))
    Next i
   
    s2.[M3].Resize(UBound(b)) = c1
    s2.[O3].Resize(UBound(b)) = c2
    s2.[Q3].Resize(UBound(b)) = c3
    s2.[s3].Resize(UBound(b)) = c4
   
Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamam." & vbLf & vbLf & _
        CDate(TimeValue(Now) - Z), vbInformation
End Sub
Genişletmek için tıkla ...

Aşağıdaki hatayı veriyor.
b = s2.Range("I3:T" & UBound(a) * 7).Value

Bunu nasıl düzeltebiliriz.
 
Böyle deneyiniz: b = s2.Range("I3:T" & s2.Cells(Rows.Count, "I").End(3).Row + 7).Value
 
Envanter sayfasında bulunmadığı için alınan hata. Koda hata satırları eklendi.

Kod: 
Sub siparisler()
Set s1 = Sheets("envanter")
Set s2 = Sheets("data")
Set s3 = Sheets("siparisler")
Set d = CreateObject("scripting.dictionary")

e = s1.Range("A2:C" & s1.Cells(Rows.Count, 1).End(3).Row).Value 'ENVANTER

    For i = 1 To UBound(e)
        d(e(i, 1)) = i
    Next i
    
a = s3.Range("A3:D" & s3.Cells(Rows.Count, 1).End(3).Row).Value


ReDim b(1 To UBound(a) * 7, 1 To 5)
ReDim b1(1 To UBound(a) * 7, 1 To 3)
ReDim b2(1 To UBound(a) * 7, 1 To 3)
    say = 1
    For i = 1 To UBound(a)
        b(say, 1) = i
        b(say, 2) = a(i, 3)
        b(say, 3) = a(i, 4)
        If d.exists(a(i, 1)) Then
            b(say, 4) = e(d(a(i, 1)), 2)
            b(say, 5) = e(d(a(i, 1)), 3)
        End If
        b1(say, 1) = Left(a(i, 1), 3)
        b1(say, 2) = a(i, 1)
        b1(say, 3) = Left(a(i, 1), InStrRev(a(i, 1), ".") - 1)
        b2(say, 1) = a(i, 2)
        say = say + 7
    Next i
    
    s2.Range("A3:L" & Rows.Count).ClearContents
    s2.[A3].Resize(say - 1, 5) = b
    s2.[H3].Resize(say - 1, 3) = b1
    s2.[L3].Resize(say - 1) = b2
    
MsgBox "İşlem tamam.", vbInformation
End Sub
 
Ziynettin' Alıntı:
Envanter sayfasında bulunmadığı için alınan hata. Koda hata satırları eklendi.

Kod: 
Sub siparisler()
Set s1 = Sheets("envanter")
Set s2 = Sheets("data")
Set s3 = Sheets("siparisler")
Set d = CreateObject("scripting.dictionary")

e = s1.Range("A2:C" & s1.Cells(Rows.Count, 1).End(3).Row).Value 'ENVANTER

    For i = 1 To UBound(e)
        d(e(i, 1)) = i
    Next i
   
a = s3.Range("A3:D" & s3.Cells(Rows.Count, 1).End(3).Row).Value


ReDim b(1 To UBound(a) * 7, 1 To 5)
ReDim b1(1 To UBound(a) * 7, 1 To 3)
ReDim b2(1 To UBound(a) * 7, 1 To 3)
    say = 1
    For i = 1 To UBound(a)
        b(say, 1) = i
        b(say, 2) = a(i, 3)
        b(say, 3) = a(i, 4)
        If d.exists(a(i, 1)) Then
            b(say, 4) = e(d(a(i, 1)), 2)
            b(say, 5) = e(d(a(i, 1)), 3)
        End If
        b1(say, 1) = Left(a(i, 1), 3)
        b1(say, 2) = a(i, 1)
        b1(say, 3) = Left(a(i, 1), InStrRev(a(i, 1), ".") - 1)
        b2(say, 1) = a(i, 2)
        say = say + 7
    Next i
   
    s2.Range("A3:L" & Rows.Count).ClearContents
    s2.[A3].Resize(say - 1, 5) = b
    s2.[H3].Resize(say - 1, 3) = b1
    s2.[L3].Resize(say - 1) = b2
   
MsgBox "İşlem tamam.", vbInformation
End Sub
[/QUOTE
çok teşekkür ederim. emeğinize sağlık
Genişletmek için tıkla ...
 

çok teşekkür ederim emeğinize sağlık
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst