• DİKKAT

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

düşey arama formulünün kodlu yazımı.

Selamlar,

Kullanıdğınız kodu aşağıdaki şekilde değiştirip denermisiniz. E sütununa veri girip deneyin.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Intersect(Target, [E3:E65536]) Is Nothing Then Exit Sub
    Set Aralık = Range("D39000:D65536")
    Set Bul = Aralık.Find(Target, [COLOR=red]LookAt:=xlWhole[/COLOR])
    If Not Bul Is Nothing Then
    Application.EnableEvents = False
        Adres = Bul.Address
        Do
        Target.Offset(0, -1) = Cells(Bul.Row, "E")
        Set Bul = Aralık.FindNext(Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    Application.EnableEvents = True
    End If
End Sub
 
Korhan bey, vermiş olduğunuz kod da sadece hücre içinde yazanın aynısıysa aldırma imkanımız varmı, Örneğin( kırmızı arabalar, dediğimde kırımızıyı buldumu hemen karşısındakini yazıyor hücrenin içindeki metnin veyahut sayının aynısı olduğunda alsın, yoksa boş bıraksın).
 
Selamlar,

Üstteki mesajımdaki kodda kırmızı renkle belirttiğim düzenlemeyi yapın ve deneyin.
 
Selamlar,

Sadece ben değil diğer arkadaşlarımda yardımcı olabilir.
 
Selamlar,

D5 hücresine;
Kod: 
=TOPLA.ÇARPIM((Sayfa1!$B$3:$B$1000>=$A$1)*(Sayfa1!$B$3:$B$1000<=$A$2)*(Sayfa1!$C$3:$C$1000=$C5))

P4 hücresine;
Kod: 
=TOPLA.ÇARPIM((Sayfa1!$B$3:$B$1000>=$A$1)*(Sayfa1!$B$3:$B$1000<=$A$2)*(Sayfa1!$C$3:$C$1000=$O4)*ESAYIYSA(MBUL(P$3;Sayfa1!$E$3:$E$1000;1)))

Formüllerini uygulayıp denermisiniz.
 
Korhan bey formulle oluyor şu anda da formulle yapmaktayım ancak, verilerimden dolayı Excel sayfası 6,8 MB oldu, formulleri kod' a çevirmeye çalışıyorumki, Excel biraz hızlansın çok yavaş ve ağır kalıyor.
 
Ayrıca bir excel sayfasının 50000 satırına A sütunu ile AB sütunu arası veri aktarımı için nasıl bir kod yazabilirim.(diğer Excel sayfasını açtığımda verilerin olduğu sayfadan alması için.) başka bir excel kitapcığına.

Aktarıma A sütunundan başlayarak AB sütununa kadar olacak, aktarım esnasında komple hücre içeriğini ve biçimini alması lazım.(kimimsinde tarih var, kimisinde sayı ve kimisinde de metin var)
 
Son düzenleme:
Selamlar,

Örnek dosyanızdaki ilk alandaki verilerin sayısı için aşağıdaki kodu denermisiniz.

Kod: 
Option Explicit
 
Sub SAY1()
    Dim S1 As Worksheet, S2 As Worksheet, X As Long
    Dim T1 As Date, T2 As Date, SAY As Long
    Dim BUL As Range, ADRES As String
 
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
 
    T1 = S2.Range("A1")
    T2 = S2.Range("A2")
 
    For X = 5 To S2.Range("C65536").End(3).Row
        Set BUL = S1.Range("C:C").Find(S2.Cells(X, "C"), LookAt:=xlWhole)
        If Not BUL Is Nothing Then
        ADRES = BUL.Address
        Do
 
        If S1.Cells(BUL.Row, "B") >= T1 And S1.Cells(BUL.Row, "B") <= T2 Then
            SAY = SAY + 1
        End If
 
        Set BUL = S1.Range("C:C").FindNext(BUL)
        Loop While Not BUL Is Nothing And BUL.Address <> ADRES
        End If
 
        S2.Cells(X, "D") = SAY
        SAY = 0
    Next
 
    Set BUL = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub


İkinci alandaki verileri saymak içinde aşağıdaki kodu denermisiniz.

Kod: 
Sub SAY2()
    Dim S1 As Worksheet, S2 As Worksheet, X As Long, Y As Byte
    Dim T1 As Date, T2 As Date
    Dim BUL As Range, ADRES As String
 
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
 
    T1 = S2.Range("A1")
    T2 = S2.Range("A2")
 
    S2.Range("P4:S65536").ClearContents
 
    For X = 4 To S2.Range("O65536").End(3).Row
        Set BUL = S1.Range("C:C").Find(S2.Cells(X, "O"), LookAt:=xlWhole)
        If Not BUL Is Nothing Then
        ADRES = BUL.Address
        Do
 
        If S1.Cells(BUL.Row, "B") >= T1 And S1.Cells(BUL.Row, "B") <= T2 Then
 
            For Y = 16 To 19
                If S1.Cells(BUL.Row, "E") Like "*" & S2.Cells(3, Y) & "*" Then
                    S2.Cells(X, Y) = S2.Cells(X, Y) + 1
                End If
            Next
 
        End If
 
        Set BUL = S1.Range("C:C").FindNext(BUL)
        Loop While Not BUL Is Nothing And BUL.Address <> ADRES
        End If
    Next
 
    Set BUL = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Korhan bey yardımlarınız için teşekkür ederim.

Ancak kodları girdim dosyada çalıştıramadım. dosya ekte
 

Ekli dosyalar

Korhan bey, şu anda kodlardan sonuçları aldım ancak her seferinde makroları çalıştırmı dememiz gerekir, yoksa herhangi bir hücreye çift tıklatsam çalıştıramazmıyım.

Ayrıca bir excel sayfasının 50000 satırına A sütunu ile AB sütunu arası veri aktarımı için nasıl bir kod yazabilirim.(diğer Excel sayfasını açtığımda verilerin olduğu sayfadan alması için.) başka bir excel kitapcığına.

Aktarıma A sütunundan başlayarak AB sütununa kadar olacak, aktarım esnasında komple hücre içeriğini ve biçimini alması lazım.(kimimsinde tarih var, kimisinde sayı ve kimisinde de metin var)
TEŞEKKÜRLER.
 
Selamlar,

Çift tıkladığınızda kodların çalışması için Sayfa2 isimli sayfanızın kod bölümüne aşağıdaki kodu uygulayın. Sayfada herhangi bir hücreye çift tıkladığınızda kod çalışacaktır.

Kod: 
Option Explicit
 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Cancel = True
    SAY1
    SAY2
End Sub
 
Korhan bey çok teşekkür ederim, kusura bakmayın, diğer veri aktarmayıda yapabilirmiyiz.
 
Selamlar,

Kitaplar arası aktarım için aşağıdaki kodu kullanabilirsiniz.

Kod: 
Option Explicit
 
Sub KİTAPLAR_ARASI_AKTAR()
    Dim K1 As Workbook, K2 As Workbook
 
    Set K1 = Workbooks("TÜM VUKUATLAR.xls")
    Set K2 = Workbooks.Open(ThisWorkbook.Path & "\" & "ARAMA SON.xls")
 
    K1.Sheets("TÜM VUKUATLAR").Range("A1:AB65536").Copy K2.Sheets("Sayfa1").Range("A1")
 
    K2.Save
    K2.Close
 
    Set K1 = Nothing
    Set K2 = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst