veri aktarılan shette il sütununda yazan ile göre başka bir sütuna belirli bir veriyi getirme

[u.L.a.s]

merhabalar

ekli excel dosyasında aşağıdaki makro kodum mevcut.
kısaca anlatmam gerekirse Tesis adlı sheet içerisinde F sütununda tıkladığım bir hücre olunca o hücrenin bulunduğu satırda bulunan bazı verileri Elektrik adlı sheet altına gönderiyorum.

şimdi burada şunu yapmak istiyorum. Elektrik sheetinde veri gelince D sütununda yazan il verisine göre H sütununa Firma ismi yazdıracağım

Örneğin D sütununda İstanbul- 34 Avr, Edirne, Tekirdağ, Kırklareli verisi aktarılmışsa H sütununda karşılığına XYZ Elektrik yazsın
D sütununda Bursa- 16, Yalova- 77 yazıyorsa, H sütununda karşılığındaki hücreye TTT Elektrik Yazsın
gibi bu şekilde ben diğer illeri aynı mantıkla yerleştiririm.

Ama burada aşağıda yazdığım kod içerisinde bu istediğim ile göre elektrik firma getirme işini yapacak kodu yazabilir miyiz

örnek dosya linki : https://s6.dosya.tc/server18/gt2u4l/Kitap1.xlsm.html

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If tarrget.Column = 6 Then
Application.ScreenUpdating = False
UserForm2.Show 0
Application .Wait(Now + TimeValue("0:00:01"))
Son = Sheet2.Range("A1000").End(3).Row + 1
Range("A" & Target.Row).Copy
Sheet2.Range("A" & Son).PasteSpecial

Range("B" & Target.Row).Copy
Sheet2.Range("B" & Son).PasteSpecial

Range("C" & Target.Row).Copy
Sheet2.Range("C" & Son).PasteSpecial

Range("D" & Target.Row).Copy
Sheet2.Range("D" & Son).PasteSpecial

Range("E" & Target.Row).Copy
Sheet2.Range("E" & Son).PasteSpecial

Range("G" & Target.Row).Copy
Sheet2.Range("F" & Son).PasteSpecial

Sheet2.Range("G" & Son) = Date

Sheet2.Range("I" & Son) = "Firmaya İletildi"

Sheets("Tesis").Select
Application.ScreenUpdating = True
Unloıfad UserForm2
End If
End Sub

 

[u.L.a.s]

kodda bazı hatalar vardı düzelttim. düzeltilmiş hali aşağıdadır

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Target.Column = 6 Then
Application.ScreenUpdating = False
'UserForm2.Show 0
'Application .Wait(Now + TimeValue("0:00:01"))
Son = Sayfa2.Range("A1000").End(3).Row + 1
Range("A" & Target.Row).Copy
Sayfa2.Range("A" & Son).PasteSpecial

Range("B" & Target.Row).Copy
Sayfa2.Range("B" & Son).PasteSpecial

Range("C" & Target.Row).Copy
Sayfa2.Range("C" & Son).PasteSpecial

Range("D" & Target.Row).Copy
Sayfa2.Range("D" & Son).PasteSpecial

Range("E" & Target.Row).Copy
Sayfa2.Range("E" & Son).PasteSpecial

Range("G" & Target.Row).Copy
Sayfa2.Range("F" & Son).PasteSpecial

Sayfa2.Range("G" & Son) = Date

Sayfa2.Range("I" & Son) = "Firmaya İletildi"

Sheets("Tesis").Select
'Application.ScreenUpdating = True
'Unloıfad UserForm2
End If
End Sub

 

[u.L.a.s]

bu kod içerisine olmasa da

ayrı bir kod yazılamaz mı

 

[necati]

Merhaba,
Kriter sayfası eklendi. Bu sayfadaki kriterleri çoğaltabilirsiniz.
Test dosyası

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Target.Column = 6 Then
    Cancel = True
    Application.ScreenUpdating = False
    Son = Sayfa2.Range("A1").End(xlDown).Row + 1
    Range("A" & Target.Row & ":E" & Target.Row).Copy
    Sayfa2.Range("A" & Son).PasteSpecial
    Range("G" & Target.Row).Copy
    
    With Sayfa2
        .Range("F" & Son).PasteSpecial
        .Range("G" & Son) = Date
        If IsError(Application.VLookup(.Range("D" & Son), Sayfa3.Range("A2:B100"), 2, False)) Then
            .Range("H" & Son) = "Kriter bulunamadı"
            .Range("H" & Son).Interior.ColorIndex = 3
        Else
            .Range("H" & Son) = Application.VLookup(.Range("D" & Son), Sayfa3.Range("A2:B100"), 2, False)
        End If
        .Range("I" & Son) = "Firmaya İletildi"
    
    End With
    Range("F" & Target.Row) = "Gönderildi"
End If
End Sub

 

[u.L.a.s]

çok teşekkür ederim üstadım. emeğine bilgine sağlık

 

[necati]

rica ederim. Application.ScreenUpdating = False satırını silmeyi unutmuşum. siz siliverin.