• DİKKAT

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

Formülü sütunun tümüne uygulamak

ASLAN7410

ASLAN7410

Katılım
15 Temmuz 2012
Mesajlar
2,802
Excel Vers. ve Dili
Ofis 2021 TR 64 Bit
Merhaba hayırlı geceler.

Ekte gönderdiğim sayfamdaki E2 ve F2 hücrelerindeki formülleri E sütununa ve F sütununa uygulamak istiyorum, bir türlü başaramadım.

Veri çok olduğu için formülle çalışma olduğundan sayfa kilitleniyor ve bazende formüller bozuluyor, bilgileri almak için butona bastığımda formül sonuçlarını almak istiyorum.

Yardımcı olur musunuz?
 

Ekli dosyalar

Son düzenleme:
Merhaba.

Örneğin aşağıdaki gibi olabilir.
.
Kod: 
[FONT="Arial Narrow"]Sub ASLAN_DİZİ_FORMÜLÜ()
[COLOR="Red"]zaman = Timer[/COLOR]
If [E65536].End(3).Row >= 2 Then Range("E2:F" & [E65536].End(3).Row).ClearContents
son = WorksheetFunction.CountA(Sheets("Sayfa2").Range("B:B"))
[E2].Formula = "=IF(INDEX(Sayfa2!E$2:E$65565,MATCH(1,IF(Sayfa2!$B$2:$B$65565=$B2,IF(Sayfa2!$D$2:$D$65565=$D2,1)),0))=0,"""",INDEX(Sayfa2!E$2:E$65565,MATCH(1,IF(Sayfa2!$B$2:$B$65565=$B2,IF(Sayfa2!$D$2:$D$65565=$D2,1)),0)))"
[E2].FormulaArray = [E2].Formula: [E2].Copy [F2]: Range("E2:F2").AutoFill Destination:=Range("E2:F" & son): Range("E2:F" & son) = Range("E2:F" & son).Value
[COLOR="red"]MsgBox "İŞLEM: " & Format(Timer - zaman, "0.000") & " saniye sürdü."[/COLOR]
End Sub[/FONT]
 
Sayın Ömer Bey, UZMAN olmuşsunuz hayırlı uğurlu olsun, gerçekten çok sevindim.

Kod için çok teşekkür ediyorum, ellerinize sağlık, Allah razı olsun.

Hayırlı çalışmalar hayırlı geceler diliyorum.
 
Eyvallah, değişen birşey yok aslında. Aynen devam.

NOT: Önceki cevabıma mavi renklendirdiğim satırı ekledim, sayfayı yenileyerek kontrol ediniz.
Maksat; varsa, eski verileri temizlemek.
.
 
Ömer Bey dediğiniz mavi renkli yerleri de ekledim gayet güzel çalışıyor.
Veri çok olduğu için biraz uzun sürüyor, bu kodun alt tarafına 00:02:00 saniye sürdü gibi bir mesaj nasıl ekleriz?
 
Verdiğim kod hücreye formülü yazma, sonucu hesaplayıp bunu değere dönüştürme şeklinde çalışıyor.
Yani avantaj sadece formül uygulanacak satır sayısına ilişkin sınırlandırma.
Aslında hızlandırmaya ilişkin, formül yöntemi dışında başka seçenekler de düşünülebilir.

Süreye ilişkin olarak ekleme yaptım. Sayfayı yenileyerek kontrol ediniz.
.
 
Merhaba,

Sn. Ömer Bey uzmanlığınızı tebrik ederim. Hayırlı olsun.

Sn. Aslan, kodu deneyip kaç satırı ne kadar zaman alıyor sonucu bildirir misiniz.

Kod: 
Option Explicit
Sub ara()
Dim a(), b(), c(), d As Object
Dim i As Long, x As Long, Krt, Say
Dim s1 As Worksheet, s2 As Worksheet
Dim Basla As Date, Bitis As Date
Application.ScreenUpdating = False
Basla = TimeValue(Now)

Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Set d = CreateObject("Scripting.Dictionary")

a = s2.Range("B2:F" & s2.Cells(Rows.Count, 2).End(3).Row)
b = s1.Range("B2:D" & s1.Cells(Rows.Count, 2).End(3).Row)

For i = 1 To UBound(a)
    Krt = a(i, 1) & "|" & a(i, 3)
    d(Krt) = a(i, 4) & "|" & a(i, 5)
Next i

ReDim c(1 To UBound(b), 1 To 2)
For x = 1 To UBound(b)
Say = Say + 1
    Krt = b(x, 1) & "|" & b(x, 3)
    If Krt <> "" Then
    c(Say, 1) = Split(d(Krt), "|")(0)
    c(Say, 2) = Split(d(Krt), "|")(1)
    End If
Next x
s1.Range("E2:F" & Rows.Count).ClearContents
If Say > 0 Then
    s1.Range("E2").Resize(Say, 2) = c
End If

Application.ScreenUpdating = True
Bitis = TimeValue(Now)

MsgBox "İşleminiz Bitti." & vbLf & vbLf & "İşlem Süreniz:  " _
    & CDate(Bitis - Basla), vbInformation
End Sub
 
Sayın Ömer sanırım bir sıkıntı var yine de bir kontrol eder misiniz?

Kodu uyguluyorum sonuç gelmiyor. Sayfayı yeniden gönderiyorum.
 

Ekli dosyalar

Teşekkürler Sayın Ziynettin.
Eminim Scripting.Dictionary yöntemi karşılaştırlamayacak kadar hızlı işlem yapacaktır.

Düzeltme: Verilerin boşluklu olmadığını düşünmüştüm.
Kod süreyi 0,266 gibi ondalık olarak vermektedir ve çalışmasında sorun yok.

son... şeklindeki satırı aşağıdakiyle değiştirerek sonuç alırsınız.

son = Sheets("Sayfa1").[B65536].End(3).Row

.
 
Sayın Zeynettin Bey sizin kod çok hızlı çalışıyor ellerinize sağlık çok teşekkür ederim, saniye olarak 00:00:00 diye yazıyor.

SAyın Ömer Bey sizin kodlarda çok güzel çalışıyor, sizin de ellerinize sağlık çok teşekkür ediyorum.

Hayırlı geceler hayırlı çalışmalar dilerim.
 
Sayın Ziynettin Bey sizi tekrar rahatsız ediyorum kusura bakmayın, hazırlamış
olduğunuz kodu kendi orijinal sayfama uyguladım hata verdi. Bir örnek ekte gönderiyorum.

Sayfa2 benim veri sayfam, bu sayfada E ve F sütununda bazı veriler olmadığı için boş.

Benim istediğim Sayfa1'deki B ve D sütunundaki veriye göre, Sayfa2'deki B ve D sütununu
karşılaştırıp E ve F sütunundaki dolu olan verileri Sayfa1'deki verilerin karşına yani E ve F sütununa yazsın.

Sayfa1'e başka veriler yapıştırdıkça, veri sayfam olan Sayfa2'den, Sayfa1'e bilgi çekmek istiyorum.

Gönderdiğim sayfayı kontrol edebilir misiniz?
 

Ekli dosyalar

Tekrar merhaba.

Sayın Ziynettin, Scripting.Dictionary yöntemini kullanarak verdiği çözümde düzenleme yapacaktır.

Ben de alternatif bir öneride bulunayım.
Bu yöntem, veri yığınının büyüklüğüne göre, Scripting.Dictionary kullanmaya nazaran yavaş, dizi formülü yönteminden hızlı sonuç verecektir.

NOT: Aşağıdaki kod'u Sayın Ziynettin'in kod'unun bulunduğu Modül dışında boş bir Modül'e uygulayarak çalıştırınız.
.
Kod: 
[FONT="Arial Narrow"]Sub BARAN()
Set s1 = Sheets("Sayfa1"): Set s2 = Sheets("Sayfa2")
Set wf = Application.WorksheetFunction: s1.Range("E2:F65536").ClearContents
s1.Activate: zaman = TimeValue(Now)
For satır = 2 To s1.[B65536].End(3).Row
If s1.Cells(satır, 2) <> "" And wf.CountIf(s2.Range("B1:B" & s2.[B65536].End(3).Row), Cells(satır, 2)) > 0 Then
s1.Cells(satır, 5) = s2.Cells(wf.Match(s1.Cells(satır, 2), s2.Range("B1:B" & s2.[B65536].End(3).Row), 0), 5)
s1.Cells(satır, 6) = s2.Cells(wf.Match(s1.Cells(satır, 2), s2.Range("B1:B" & s2.[B65536].End(3).Row), 0), 6)
End If: Next: MsgBox "İşlem Süresi  : " & CDate(TimeValue(Now) - zaman)
End Sub[/FONT]
 
Sayın Ömer Bey sizi yordum kusura bakmayın vallahi çok süper oldu kod hatasız çalışıyor veri getirmesi 1 saniye sürdü.

Allah razı olsun hayırlı geceler.
 
ASLAN7410' Alıntı:
Sayın Ziynettin Bey sizi tekrar rahatsız ediyorum kusura bakmayın, hazırlamış
olduğunuz kodu kendi orijinal sayfama uyguladım hata verdi. Bir örnek ekte gönderiyorum.

Sayfa2 benim veri sayfam, bu sayfada E ve F sütununda bazı veriler olmadığı için boş.

Benim istediğim Sayfa1'deki B ve D sütunundaki veriye göre, Sayfa2'deki B ve D sütununu
karşılaştırıp E ve F sütunundaki dolu olan verileri Sayfa1'deki verilerin karşına yani E ve F sütununa yazsın.

Sayfa1'e başka veriler yapıştırdıkça, veri sayfam olan Sayfa2'den, Sayfa1'e bilgi çekmek istiyorum.

Gönderdiğim sayfayı kontrol edebilir misiniz?
Genişletmek için tıkla ...

Aranılan kriter bulunamadığında hata verir. Bu hata satırlarını atlamak için On Erorr Resume Next deyimini koda ekleyiniz.

Kod: 
Option Explicit
Sub DüşeyAra()
Dim a(), b(), c(), d As Object
Dim i As Long, x As Long, Krt, Say
Dim s1 As Worksheet, s2 As Worksheet
Dim Basla As Date, Bitis As Date
Application.ScreenUpdating = False
Basla = TimeValue(Now)
[COLOR="Red"]On Error Resume Next[/COLOR]
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Set d = CreateObject("Scripting.Dictionary")

a = s2.Range("B2:F" & s2.Cells(Rows.Count, 2).End(3).Row)
b = s1.Range("B2:D" & s1.Cells(Rows.Count, 2).End(3).Row)

For i = 1 To UBound(a)
    Krt = a(i, 1) & "|" & a(i, 3)
    d(Krt) = a(i, 4) & "|" & a(i, 5)
Next i

ReDim c(1 To UBound(b), 1 To 2)
For x = 1 To UBound(b)
Say = Say + 1
    Krt = b(x, 1) & "|" & b(x, 3)
    If Krt <> "" Then
    c(Say, 1) = Split(d(Krt), "|")(0)
    c(Say, 2) = Split(d(Krt), "|")(1)
    End If
Next x
s1.Range("E2:F" & Rows.Count).ClearContents
If Say > 0 Then
    s1.Range("E2").Resize(Say, 2) = c
End If

Application.ScreenUpdating = True
Bitis = TimeValue(Now)

MsgBox "İşleminiz Bitti." & vbLf & vbLf & "İşlem Süreniz:  " _
    & CDate(Bitis - Basla), vbInformation
End Sub
 
Sayın Ziynettin Bey çok teşekkür ediyorum, Allah razı olsun, tam istediğim gibi oldu.


Hayırlı çalışmalar hayırlı geceler diliyorum.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst