Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > EXCEL-Soruları > Makro-VBA
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Makro-VBA Makro veya VBA ile ilgili sorularınızı buraya gönderebilirsiniz.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 12-01-2018, 14:31   #1
aksoy53
Altın Üye
 
Giriş: 21/11/2007
Şehir: RİZE
Mesaj: 81
Excel Vers. ve Dili:
windows 10
Varsayılan Barkodla Sayım Tarama

Yardım yapabilirmisiniz

TKYS Listedeki kitapların Demirbaş numarasına göre tarayacak.

Eğer listede varsa o demirbaş numarasını Bulunan Demirbaş Listesine Ekleyecek ve bu ekranda
bulunduğunu söyleyecek ya da YEŞİL yanacak.

Eğer listede YOK ise Bulunamayan Demirbaşlar Listesine ekleyecek ve Ekran Kırmızı yanacak ya da YOK diyecek
Eklenmiş Dosyalar
Dosya Türü: xlsx Yetişkin-Kitaplar-KOHA_TKYS-Eşleştirme.xlsx (470.6 KB, 10 Görüntülenme)
aksoy53 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 12-01-2018, 16:47   #2
YUSUF44
Destek Ekibi
 
YUSUF44 kullanıcısının avatarı
 
Giriş: 04/01/2006
Şehir: Manisa, Kula
Mesaj: 6,508
Excel Vers. ve Dili:
İş : Ofis 2016 - Türkçe Ev: Ofis 2016 - Türkçe
Varsayılan

Aşağıdaki kodları Tarama sayfasının kod bölümüne (sayfa ismine sağ tıklayıp kod görüntüle deyince açılan sayfaya) yapıştırın. C10 hücresi değiştiğinde istediğiniz işlemi yapar:

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C10]) Is Nothing Then Exit Sub
Set s1 = Sheets("TKYS LİSTE")
Set s2 = Sheets("BULUNAN DEMİRBAŞ LİSTESİ")
Set s3 = Sheets("BULUNAMAYAN DEMİRBAŞLAR")
son = s1.Cells(Rows.Count, "A").End(3).Row

If WorksheetFunction.CountIf(s1.Range("A1:A" & son), Target) > 0 Then
    yeni = s2.Cells(Rows.Count, "A").End(3).Row + 1
    If s2.[A1] = "" Then yeni = 1
    s2.Cells(yeni, "A") = Target
    Target.Interior.Color = vbGreen
Else
    
    yeni = s3.Cells(Rows.Count, "A").End(3).Row + 1
    If s3.[A1] = "" Then yeni = 1
    s3.Cells(yeni, "A") = Target
    Target.Interior.Color = vbRed

End If

End Sub
__________________


Sorularınızı örnek dosyayla desteklemeniz çözüme ulaşmanızı kolaylaştırır.

Altın Üye olmanızı öneririm. Altın Üye değilseniz dosyanızı dosya yükleme sitelerinden birine yükleyip linkini paylaşabilirsiniz.
YUSUF44 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 12-01-2018, 18:59   #3
aksoy53
Altın Üye
 
Giriş: 21/11/2007
Şehir: RİZE
Mesaj: 81
Excel Vers. ve Dili:
windows 10
Varsayılan

Çok teşekkür ederim çok değerli ve kayda değerleriniz için bir kez daha teşekkür ederim. Güzel oldu fakat hocam rica etsem 2 tane maddeyi yapabilirmisiniz. çok makbule geçer.

1-tarama sayfasındaki "C10" barkod alaına barkod okutugumda imleç alt hücreye geçmesin sabit kalsın her okuttuğumda orda kalsın
2-Varolan demirbaşlar numaraları TKYS LİSTE de sarı renk olsun
aksoy53 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 12-01-2018, 20:17   #4
YUSUF44
Destek Ekibi
 
YUSUF44 kullanıcısının avatarı
 
Giriş: 04/01/2006
Şehir: Manisa, Kula
Mesaj: 6,508
Excel Vers. ve Dili:
İş : Ofis 2016 - Türkçe Ev: Ofis 2016 - Türkçe
Varsayılan

Aşağıdaki gibi deneyin:

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [C10]) Is Nothing Then Exit Sub
Set s1 = Sheets("TKYS LİSTE")
Set s2 = Sheets("BULUNAN DEMİRBAŞ LİSTESİ")
Set s3 = Sheets("BULUNAMAYAN DEMİRBAŞLAR")
son = s1.Cells(Rows.Count, "A").End(3).Row

If WorksheetFunction.CountIf(s1.Range("A1:A" & son), Target) > 0 Then
    yeni = s2.Cells(Rows.Count, "A").End(3).Row + 1
    If s2.[A1] = "" Then yeni = 1
    s2.Cells(yeni, "A") = Target
    Target.Interior.Color = vbGreen
    Set c = s1.[A:A].Find(Target)
    If Not c Is Nothing Then c.Interior.Color = vbYellow

Else
    
    yeni = s3.Cells(Rows.Count, "A").End(3).Row + 1
    If s3.[A1] = "" Then yeni = 1
    s3.Cells(yeni, "A") = Target
    Target.Interior.Color = vbRed

End If
Target.Select
End Sub
İyi çalışmalar.
__________________


Sorularınızı örnek dosyayla desteklemeniz çözüme ulaşmanızı kolaylaştırır.

Altın Üye olmanızı öneririm. Altın Üye değilseniz dosyanızı dosya yükleme sitelerinden birine yükleyip linkini paylaşabilirsiniz.
YUSUF44 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 12-01-2018, 20:30   #5
aksoy53
Altın Üye
 
Giriş: 21/11/2007
Şehir: RİZE
Mesaj: 81
Excel Vers. ve Dili:
windows 10
Varsayılan

Çok teşekkür ederim ellerin dert görmesin
aksoy53 Çevrimdışı   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 03:05


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Web Tasarım -- Beylikdüzü mali müşavir - Lingerie - Dyeing Machine - Karton Bardak- Karton Bardak- Çorlu Dil Konuşma Terapisti- Çorlu Özel Eğitim- Site Yönetimi- Pronet Tekirdağ- Çorlu Kamera- Pronet Edirne- Pronet Çorlu- Çorlu Araç Takip- Çorlu Su Arıtma- Gebze Emlak- Rampa- Rotary- Çorlu İnternet Sitesi- Çorlu Sürücü Kursu- Çorlu Sürücü Kursu- Şişli Avukat- Edirne Serbest Muhasebeci- Çorlu Etüt- İstanbul Botanik- Çorlu Sigorta- Kağıt Bardak- Kaplan Tekstil- Çorlu Perde- Çorlu Havuz- Makina- Danışmazlar-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden