• DİKKAT

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

İki ayrı Cahenge kodunu birleştirme

T

tahsinanarat

Altın Üye
Katılım
14 Mart 2005
Mesajlar
2,181
Excel Vers. ve Dili
Ofis 2019 Türkçe
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim hcr As Range, syf As Integer
If Intersect(Target, Range("c:c")) Is Nothing Then Exit Sub
If Target = "" Then Exit Sub

    Set hcr = Sheets("STOK").Cells.Find(Target, lookat:=xlWhole)
        If Not hcr Is Nothing Then
            Sheets("STOK").Select
            hcr.Select
        End If

Set hcr = Nothing
End Sub
Yukarıda verdiğim kod ile eklediğim örnek dosyanın satış sayfasının C sütununda bulunan model numaralarında herhangi birinde F2 enter yaptığında STOK sayfasında eşleşen ilk model numarasına gidiyor.
---------------------------------
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim BUL As Range
    On Error GoTo Son
If Intersect(Target, Range("I2:I65536")) Is Nothing Then Exit Sub
    If Target = "" Then
    Else
        Set BUL = Sheets("database").Range("L:L").Find(Target)
        If Not BUL Is Nothing Then
        Target.Offset(0, -6).Value = BUL.Offset(0, -11).Value
        Target.Offset(0, -5).Value = BUL.Offset(0, -9).Value
        Target.Offset(0, -4).Value = BUL.Offset(0, -2).Value
        Target.Offset(0, -1).Value = Date
        'Target.Offset(0, 1).Value = BUL.Offset(0, 6).Value
     End If
    End If
For Sat = 2 To 65
If Cells(Sat, 9) = "" Then
'Rows(sat).Delete
Rows(Sat).ClearContents
End If
Next
Son:
End Sub

Bu kod eile, satış fişinen J sütununda yazılı bulunan barkodları database sayfasından model ve renk numaralarını getirmektedir.

Bu iki kod ayrı ayrı çalışmasında herhangi bir sıkıntı yok.
Benim istediğim her iki kodu birleştirerek Satış irsaliyesinde de C sütununda herhangi bir model numarısında F2 enter yaptığımda yine STOK Sayfasında ilk eşleşen Model numaraya gitmesi.
Her iki kodun birleştirmesini ne yaptımsa iki kodu bir arada çalıştıramadım, uzman arkadaşlardan yardım talep ediyorum.

Örnek dosyam etkedir.
 

Ekli dosyalar

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim hcr As Range, syf As Integer
If Intersect(Target, Range("c:c")) Is Nothing Then goto 10
If Target = "" Then Exit Sub

Set hcr = Sheets("STOK").Cells.Find(Target, lookat:=xlWhole)
If Not hcr Is Nothing Then
Sheets("STOK").Select
hcr.Select
End If

Set hcr = Nothing
10
Dim BUL As Range
On Error GoTo Son
If Intersect(Target, Range("I2:I65536")) Is Nothing Then Exit Sub
If Target = "" Then
Else
Set BUL = Sheets("database").Range("L:L").Find(Target)
If Not BUL Is Nothing Then
Target.Offset(0, -6).Value = BUL.Offset(0, -11).Value
Target.Offset(0, -5).Value = BUL.Offset(0, -9).Value
Target.Offset(0, -4).Value = BUL.Offset(0, -2).Value
Target.Offset(0, -1).Value = Date
'Target.Offset(0, 1).Value = BUL.Offset(0, 6).Value
End If
End If
For Sat = 2 To 65
If Cells(Sat, 9) = "" Then
'Rows(sat).Delete
Rows(Sat).ClearContents
End If
Next
Son:
End Sub
Genişletmek için tıkla ...

Bu şekil deneyiniz.
 
Sn. Muhammed Okumuş, ilginiz için teşekkür ediyorum, ancak kod tam istediğim gibi çalışmıyor, şöyleki, j sütununda barkod numarasını yazdığım anda c sütunundaki model numarasına yanı stok sayfasını götürüyor, ben c sütununda F2 enter yaparsam götürmesi gerekiyor, umarım anlatabilmişimdir.
 
Ben olayı yanlış anlamışım. F2 tuşuna ait kodu göremedim.
 
Hocam, şöyle izah edeyim, sizin birleştirdiğiniz kodlar barkod okutulduğunda (yazıldıında) önce benim verdiğim ikinci kod sonra aynı anda verdiğim birinci kod çalışıyor. Benim istediğim tam tersi olacak önce ikinci verdiğim kod çalışacak, ben istersim c sütununda model noyu yazdığımda yada hücre içine girip enter dediğimde verdiğim birinci kod çalışacak, yani öncelik kod bilgilerinin getirilmesinde, sonra istenildiğimde birinci verdiğim kod devreye girecek şekilde birleştirebilirmiyiz.
 
Son düzenleme:
Yani siz 2. kod çalıştırdığımda işlemi yapsın ve satış sayfasına mı geçsin istiyorsunuz?
 
Valla hocam kusura bakmayın tam idrak edemedim. İsteklerinizi madde madde yazar mısınız?
 
1-
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim BUL As Range
    On Error GoTo Son
If Intersect(Target, Range("I2:I65536")) Is Nothing Then Exit Sub
    If Target = "" Then
    Else
        Set BUL = Sheets("database").Range("L:L").Find(Target)
        If Not BUL Is Nothing Then
        Target.Offset(0, -6).Value = BUL.Offset(0, -11).Value
        Target.Offset(0, -5).Value = BUL.Offset(0, -9).Value
        Target.Offset(0, -4).Value = BUL.Offset(0, -2).Value
        Target.Offset(0, -1).Value = Date
        'Target.Offset(0, 1).Value = BUL.Offset(0, 6).Value
     End If
    End If
For Sat = 2 To 65
If Cells(Sat, 9) = "" Then
'Rows(sat).Delete
Rows(Sat).ClearContents
End If
Next
Son:
End Sub
Hocam izah ediyorum:

önce bu kod çalışacak, j sütunundaki barkod bilgilerini çekecek. Bu kodun işi tamam,
2- Satış irsaliyesinde iken C sütununda yazılı bulunan model numarasına tıkladığımda (içine girip enterladığımda) stok sayfasında ilk eşleşen numaraya gidiyor,
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim hcr As Range, syf As Integer
If Intersect(Target, Range("c:c")) Is Nothing Then Exit Sub
If Target = "" Then Exit Sub

    Set hcr = Sheets("STOK").Cells.Find(Target, lookat:=xlWhole)
        If Not hcr Is Nothing Then
            Sheets("STOK").Select
            hcr.Select
        End If

Set hcr = Nothing
End Sub
Bu kodlar o işi yapıyor,
Birleştirmeyi bu şekilde yapmak istiyorum. Yani ben istemezsem STOK sayfasına gitmeyecek.
 
Hocam o zaman bunu change olayına değil de kodları düğmeye atamak gerek. Düğmeye bastığınızda veya F2 tuşuna bastığınızda Stok sayfasına gider.
 
Sn. Muhammet Hocam şöyle bir çözüm buldum, sizin birleştirmiş olduğunuz koddan faydalanarak;

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim hcr As Range, syf As Integer
If Intersect(Target, Range("N1")) Is Nothing Then GoTo 10
If Target = "" Then Exit Sub

Set hcr = Sheets("STOK").Cells.Find(Target, lookat:=xlWhole)
If Not hcr Is Nothing Then
Sheets("STOK").Select
hcr.Select
End If

Set hcr = Nothing
10
Dim BUL As Range
On Error GoTo Son
If Intersect(Target, Range("I2:I65536")) Is Nothing Then Exit Sub
If Target = "" Then
Else
Set BUL = Sheets("database").Range("L:L").Find(Target)
If Not BUL Is Nothing Then
Target.Offset(0, -6).Value = BUL.Offset(0, -11).Value
Target.Offset(0, -5).Value = BUL.Offset(0, -9).Value
Target.Offset(0, -4).Value = BUL.Offset(0, -2).Value
Target.Offset(0, -1).Value = Date
'Target.Offset(0, 1).Value = BUL.Offset(0, 6).Value
End If
End If
For Sat = 2 To 65
If Cells(Sat, 9) = "" Then
'Rows(sat).Delete
Rows(Sat).ClearContents
End If
Next
Son:
End Sub

---------------------------------
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Application.CutCopyMode = xlCopy Then Exit Sub
If Application.CutCopyMode = xlCut Then Exit Sub
If Not Intersect(Target, Range("C:C")) Is Nothing Then
[N1] = ActiveCell.Text
End If
Dim Satır As Range, Sütun As Range
Set Satır = Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 256))
Set Sütun = Range(Cells(1, ActiveCell.Column), Cells(65536, ActiveCell.Column))
Cells.FormatConditions.Delete
With Satır
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 6
End With
With ActiveCell
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=1
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 2
End With
End Sub

c sütunununda aktif hücreyi N1 hücresine atadım. C sütununda model numarasını seçtiğim anda STOK sayfasında ilk eşleşen numaraya gidiyor. Sizi yordum, hakkınızı helal edin. Teşekkür ederim.
 
Rica ederim.
F2 tuşuna kod atamak istiyorsanız.

Sub AUTO_OPEN()
Application.OnKey "{F2}", "STOK"
End Sub

Sub AUTO_CLOSE()
Application.OnKey "{F2}", ""
End Sub


Sub STOK()

Dim hcr As Range, syf As Integer
r = ActiveCell.Row
c = ActiveCell.Column
If c <> 3 Or ActiveCell = "" Then Exit Sub


Set hcr = Sheets("STOK").Cells.Find(ActiveCell, lookat:=xlWhole)
If Not hcr Is Nothing Then

Sheets("STOK").Select
hcr.Select
End If

Set hcr = Nothing

End Sub
Genişletmek için tıkla ...

Kodlarını kullanabilirsiniz.
 
Verinin üzerine çift tıklayarak da kodları çalıştırabilirsiniz.
 
Hocam, F2 kodlarını çalıştıramadım, örnek dosyama entegre edip buraya yükleyebilirmisiniz.

Tamam hocam hallettim, çok teşekkür ederim, bence bu daha kullanışlı olacak.
 
Klavyeniz diz üstü ise Fn+F2 ile birlikte çalıştırınız. Aktif hücre C sütununda olmalı
 

Ekli dosyalar

Merhaba,
Change kodlarını şu şekilde kullanırsanız istediğiniz kadar ekleyebilirsiniz.
Kod: 
If Not Intersect(Target, Range("c:c")) Is Nothing Then
.......'Kodlarınız
End if
If Not Intersect(Target, Range("l:l")) Is Nothing Then
........''kodlarınız
end if
 
Sn. leumruk, dediğiniz şekilde yapmaya çalıştım ancak bir türlü halledemedim, bu iki kodu birleştirebilirmisiniz, nerde hata yaptığımı öğrenmiş olurum.
 
Sizin kodlar farklı sayfalarda çalışıyor. Bu yüzden kodlarda sayfa tanimlamasi yapin.
 
Kod: 
Sub STOK()

Dim hcr As Range, syf As Integer
r = ActiveCell.Row
c = ActiveCell.Column
If c <> 3 Or ActiveCell = "" Then Exit Sub


Set hcr = Sheets("STOK").Cells.Find(ActiveCell, lookat:=xlWhole)
If Not hcr Is Nothing Then

Sheets("STOK").Select
hcr.Select
End If

Set hcr = Nothing

End Sub

yukarıdaki kod saadece 3.sutun (c sutun) da işlem yapıyor, bunu A ve B sütunları içinde çalıştırılabilirmi, yani a,b ve c sütununda hangi model numarasını seçsem beni stok sayfasına eşleşen numaraya götürebilirmi.
örnek dosyam ilk mesajımın ekinde mevcut.
 
Arama sütununu iptal edip aktif hücre değerini arattırarak bu şekilde çözüm buldum,
Kod: 
Sub STOK()
Dim hcr As Range, syf As Integer
If ActiveCell = "" Then Exit Sub
Set hcr = Sheets("STOK").Cells.Find(ActiveCell, lookat:=xlWhole)
If Not hcr Is Nothing Then
Sheets("STOK").Select
hcr.Select
End If
Set hcr = Nothing
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst