hücre değerindeki sayfa adına göre aktarma

[mehmetkoca]

Arkadaşlar merhaba;
Ekteki dosyada bir veri sayfası ve çalışanların adına göre oluşturduğum sayfalar mevcut.Veri sayfasında aktar-sil makrosu kullanarak B sütunundaki çalışan isimlerine göre sayfalara aktarma yapmak istiyorum.Makro aktif satırdayken çalışmalı.Çünkü aktarmaları günü geldiğinde tek tek yapıyorum.Birde örneğin B sütununda yazılan çalışan ismine göre bir sayfa yoksa uyarı versin ,yada otomatik o isimde bir sayfa açsın.

Örnek dosya ektedir.
Değerli yardımlarınız için teşekkür ederim arkadaşlar.
Saygılarımla.

 

[mehmetkoca]

Yardımcı olabilirmisiniz arkadaşlar

 

[mehmetkoca]

Sub aktar_sil()
Dim sat As Long
If ActiveSheet.Name <> "veri" Then Exit Sub
If ActiveCell.Row < 2 Then Exit Sub
If ActiveCell.Column > 8 Then Exit Sub
If ActiveCell.Row > Cells(65536, "C").End(xlUp).Row Then Exit Sub
With Sheets("cevdet")
    sat = .Cells(65536, "C").End(xlUp).Row + 1
    If sat > 65533 Then
        MsgBox "sevkedilen sayfasında satır doldu.Kayıt aktarılamadı ve silinemedi", vbCritical, "UYARI"
        Exit Sub
    End If
    .Range("A" & sat & ":p" & sat).Value = Range("A" & ActiveCell.Row & ":p" & ActiveCell.Row).Value
End With
Rows(ActiveCell.Row).Delete
End Sub

arkadaşlar yukarıdaki kodla aktif satırı örneğin cevdet sayfasına aktarabiliyorum.B sütunundaki isme göre ilgili sayfaya aktarabilmem için koda nasil bir ilave yapabilirim.

İlgi ve yardımlarınız için teşekkürler.

 

[Necdet]

Merhaba,

Kendi mantığımla yanıt vereyim. Aşağıdaki sayfa ile ilgili kodları ya da hepsini "veri" sayfasının kod bölümüne kopyalayabilirsiniz.

Genel amaçlı olarak yazmaya çalıştım, Sütun sayısı önemli değil. İlgili satırda çift tıklandığında sayfa kontrolü yapar, yoksa açar ve aktarır.


İlgili sayfada olması gereken kod :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    
    Dim Sayfa   As String
    Dim Sat     As Long
    Dim i       As Long
    Dim Kol     As Integer
    
    Sat = Target.Row
    Kol = Cells(1, Columns.Count).End(1).Column
    
    Sayfa = BKH(Trim(Cells(Target.Row, "B")), 2)
    
    If Sayfa = "" Then
        MsgBox "MONTAJ EKİBİ BELLİ DEĞİL....", vbCritical
        Exit Sub
    End If
    
    If Sayfa_Var_Yok(Sayfa) = False Then
        Application.ScreenUpdating = False
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = Sayfa
        Sheets("veri").Select
        Range(Cells(1, "A"), Cells(1, Kol)).Copy Sheets(Sayfa).Range("A1")
        Application.ScreenUpdating = True
    End If
        
    i = Sheets(Sayfa).Cells(Rows.Count, "B").End(3).Row + 1
    Range(Cells(Sat, "A"), Cells(Sat, Kol)).Copy Sheets(Sayfa).Range("A" & i)
    
End Sub

Aşağıdaki 2 adet Funcion ilgili sayfada da olabilir, ayrı bir modülde de olabilir.

Ayrı modülde olduğunda her Sub içinde kullanabilirsiniz.

Function Sayfa_Var_Yok(Sh_Name As String) As Boolean
    
    On Error Resume Next
    Sayfa_Var_Yok = CBool(Len(Worksheets(Sh_Name).Name) > 0)
    
End Function

Function BKH(Sozcuk As String, Optional Tip As Integer) As String
    'Tip    1. Küçük Harf
    '       2. Büyük Harf
    '       3. Yazım Düzeni
    
    If Tip = 1 Then
        BKH = Evaluate("=LOWER(" & """" & Sozcuk & """" & ")")
    ElseIf Tip = 2 Then
        BKH = Evaluate("=UPPER(" & """" & Sozcuk & """" & ")")
    Else
        BKH = Application.WorksheetFunction.Proper(Sozcuk)
    End If
    
End Function

 

[mehmetkoca]

Sayın Necdet Bey ; Emeğiniz ve yardımlarınız için teşekkür ederim.
Verdiğiniz kodla sorun çözülmüştür.
İyi Geceler.

 

[Necdet]

Sayın Necdet Bey ; Emeğiniz ve yardımlarınız için teşekkür ederim.
Verdiğiniz kodla sorun çözülmüştür.
İyi Geceler.

Güle güle kullanınız.