Otomatik Referanslama Yapma

M

my_gan

Katılım
8 Kasım 2008
Mesajlar
53
Excel Vers. ve Dili
microsoft office 2016 professional plus 2016
Ekte buradan ÖmerBey adlı kullanıcının yardımı ile makrolu bir çalışma elde etmiştik. Bu makrolu çalışmaya firmaların muhasebelerinden aldığım verileri alıp içeri yedirdiğimde fiş numaralarına çift tıkladığımda( f stünuna) mahsup fişlerini otomatik olarak ikinci sekmede görebiliyordum.

Şimdi yapmak istediğim; yüklemiş olduğum dosyanın K stünuna referans başlığı ekledim.
Ekteki örneğe göre filtreleme yaptığım 102 hesapta bazı satırlara referans numarası eklemek istiyorum. Ekteki çalışmada K10 hücresine referans numarası yazdım. Bu yazdığım referans numarası 7385 no.lu fişin diğer ilgili satırlarına otomatik gelmesini sağlayabilir miyim ?
Hatta K stünunda ilgili hücreye çift tıkladığımda referans numarası otomatik 1 den başlasa ve ilgili diğer hücreye de bu numara otomatik gitse, başka hücreye tıkladığımda otomatikmen 2'den başlasa çok iyi olur.
Bu konuda yardımcı olacaklara şimdiden çok teşekkür ediyorum.

İndir örnek çalışma

Dosyayı indir örnek çalışma
dosya.co
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,515
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Range("F:F")) Is Nothing Then
        Dim s1 As Worksheet, s2 As Worksheet
        Dim kopya As Range, a As Long, X As Long
        Cancel = True
        Set s1 = Sheets("Muavin")
        Set s2 = Sheets("Mahsup Fişi")
        Application.EnableEvents = True
        Application.ScreenUpdating = False
        s2.UsedRange.Clear
        s1.Range("A1:I1").Copy s2.Range("A1")
        For a = 2 To s1.UsedRange.Rows.Count
            If s1.Cells(a, "F") = Target.Value Then
                X = s2.Cells(Rows.Count, "F").End(3).Row + 1
                s2.Range("A" & X & ":I" & X).Value = s1.Range("A" & a & ":I" & a).Value
            End If
        Next
        Target.EntireRow.Copy
        s2.Rows("2:" & X).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
        s2.Activate
        s2.Range("A1").Select
        Application.ScreenUpdating = True
        Application.EnableEvents = True
    ElseIf Not Intersect(Target, Range("K:K")) Is Nothing Then
        Dim Referans_Kodu As Long, Son As Long, Veri As Variant
        On Error Resume Next
        ActiveSheet.ShowAllData
        On Error GoTo 0
        Referans_Kodu = WorksheetFunction.Max(Range("K:K")) + 1
        Son = Cells(Rows.Count, 1).End(3).Row
        Veri = Range("A2:K" & Son).Value
        ReDim Liste(1 To UBound(Veri), 1 To 1)
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            If Veri(X, 6) = Cells(Target.Row, "F") Then
                Liste(X, 1) = Referans_Kodu
            Else
                Liste(X, 1) = Veri(X, 11)
            End If
        Next
        Range("K2").Resize(UBound(Liste)) = Liste
    End If
End Sub
 
M

my_gan

Katılım
8 Kasım 2008
Mesajlar
53
Excel Vers. ve Dili
microsoft office 2016 professional plus 2016
Korhan Ayhan' Alıntı:
Deneyiniz.

C++: 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Range("F:F")) Is Nothing Then
        Dim s1 As Worksheet, s2 As Worksheet
        Dim kopya As Range, a As Long, X As Long
        Cancel = True
        Set s1 = Sheets("Muavin")
        Set s2 = Sheets("Mahsup Fişi")
        Application.EnableEvents = True
        Application.ScreenUpdating = False
        s2.UsedRange.Clear
        s1.Range("A1:I1").Copy s2.Range("A1")
        For a = 2 To s1.UsedRange.Rows.Count
            If s1.Cells(a, "F") = Target.Value Then
                X = s2.Cells(Rows.Count, "F").End(3).Row + 1
                s2.Range("A" & X & ":I" & X).Value = s1.Range("A" & a & ":I" & a).Value
            End If
        Next
        Target.EntireRow.Copy
        s2.Rows("2:" & X).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
        s2.Activate
        s2.Range("A1").Select
        Application.ScreenUpdating = True
        Application.EnableEvents = True
    ElseIf Not Intersect(Target, Range("K:K")) Is Nothing Then
        Dim Referans_Kodu As Long, Son As Long, Veri As Variant
        On Error Resume Next
        ActiveSheet.ShowAllData
        On Error GoTo 0
        Referans_Kodu = WorksheetFunction.Max(Range("K:K")) + 1
        Son = Cells(Rows.Count, 1).End(3).Row
        Veri = Range("A2:K" & Son).Value
        ReDim Liste(1 To UBound(Veri), 1 To 1)
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            If Veri(X, 6) = Cells(Target.Row, "F") Then
                Liste(X, 1) = Referans_Kodu
            Else
                Liste(X, 1) = Veri(X, 11)
            End If
        Next
        Range("K2").Resize(UBound(Liste)) = Liste
    End If
End Sub
Genişletmek için tıkla ...
Korhan Bey elinize sağlık çok teşekkür ederim. Yalnız makroyu bir türlü excelin içine yediremedim.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,515
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Varolan BeforeDoubleClick olayını silip yenisini uygulayacaksınız.
 
M

my_gan

Katılım
8 Kasım 2008
Mesajlar
53
Excel Vers. ve Dili
microsoft office 2016 professional plus 2016
Korhan Ayhan' Alıntı:
Varolan BeforeDoubleClick olayını silip yenisini uygulayacaksınız.
Genişletmek için tıkla ...
Korhan Bey oldu çok teşekkür ederim. Benim deneme yaptığım excelde K stünunda başka veri olduğu için yapamadım. Bunu fark edince otomatik oldu.
Konu ile ilgili çok ufak bir şey daha isteyebilir miyim ?
Filtreleme halinde K stünuna çift tıklayınca referans numarası veriyor ama filtrelemeyi otomatik iptal ediyor. Bunu giderebilir miyiz acaba ?
Şimdiden çok teşekkür ederim Korhan Bey.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,515
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Ben veri sayınızın çoğalma durumunu düşünerek dizi yöntemi ile çözüm sunmuştum.

Filtre kalması gerekiyorsa aşağıdaki kodu kullanabilirsiniz. Fakat veri sayınız çoğalırsa yavaşlama yaşayabilirsiniz.

C++: 
Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Range("F:F")) Is Nothing Then
        Dim s1 As Worksheet, s2 As Worksheet
        Dim kopya As Range, a As Long, X As Long
        Cancel = True
        Set s1 = Sheets("Muavin")
        Set s2 = Sheets("Mahsup Fişi")
        Application.EnableEvents = True
        Application.ScreenUpdating = False
        s2.UsedRange.Clear
        s1.Range("A1:I1").Copy s2.Range("A1")
        For a = 2 To s1.UsedRange.Rows.Count
            If s1.Cells(a, "F") = Target.Value Then
                X = s2.Cells(Rows.Count, "F").End(3).Row + 1
                s2.Range("A" & X & ":I" & X).Value = s1.Range("A" & a & ":I" & a).Value
            End If
        Next
        Target.EntireRow.Copy
        s2.Rows("2:" & X).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
        s2.Activate
        s2.Range("A1").Select
        Application.ScreenUpdating = True
        Application.EnableEvents = True
    ElseIf Not Intersect(Target, Range("K:K")) Is Nothing Then
        Dim Referans_Kodu As Long, Son As Long, Veri As Range
        Referans_Kodu = WorksheetFunction.Max(Range("K:K")) + 1
        If ActiveSheet.AutoFilterMode = False Then
            Son = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Else
            With ActiveSheet.AutoFilter.Range
                Son = .Row + .Rows.Count - 1
            End With
        End If
        For Each Veri In Range("F2:F" & Son)
            If Veri.Value = Cells(Target.Row, "F") Then
                Veri.Offset(, 5) = Referans_Kodu
            End If
        Next
    End If
End Sub
 
M

my_gan

Katılım
8 Kasım 2008
Mesajlar
53
Excel Vers. ve Dili
microsoft office 2016 professional plus 2016
Korhan Ayhan' Alıntı:
Ben veri sayınızın çoğalma durumunu düşünerek dizi yöntemi ile çözüm sunmuştum.

Filtre kalması gerekiyorsa aşağıdaki kodu kullanabilirsiniz. Fakat veri sayınız çoğalırsa yavaşlama yaşayabilirsiniz.

C++: 
Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Range("F:F")) Is Nothing Then
        Dim s1 As Worksheet, s2 As Worksheet
        Dim kopya As Range, a As Long, X As Long
        Cancel = True
        Set s1 = Sheets("Muavin")
        Set s2 = Sheets("Mahsup Fişi")
        Application.EnableEvents = True
        Application.ScreenUpdating = False
        s2.UsedRange.Clear
        s1.Range("A1:I1").Copy s2.Range("A1")
        For a = 2 To s1.UsedRange.Rows.Count
            If s1.Cells(a, "F") = Target.Value Then
                X = s2.Cells(Rows.Count, "F").End(3).Row + 1
                s2.Range("A" & X & ":I" & X).Value = s1.Range("A" & a & ":I" & a).Value
            End If
        Next
        Target.EntireRow.Copy
        s2.Rows("2:" & X).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
        s2.Activate
        s2.Range("A1").Select
        Application.ScreenUpdating = True
        Application.EnableEvents = True
    ElseIf Not Intersect(Target, Range("K:K")) Is Nothing Then
        Dim Referans_Kodu As Long, Son As Long, Veri As Range
        Referans_Kodu = WorksheetFunction.Max(Range("K:K")) + 1
        If ActiveSheet.AutoFilterMode = False Then
            Son = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Else
            With ActiveSheet.AutoFilter.Range
                Son = .Row + .Rows.Count - 1
            End With
        End If
        For Each Veri In Range("F2:F" & Son)
            If Veri.Value = Cells(Target.Row, "F") Then
                Veri.Offset(, 5) = Referans_Kodu
            End If
        Next
    End If
End Sub
Genişletmek için tıkla ...
Elinize sağlık Korhan Bey. Tam istediğim gibi oldu.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst