Soru Farklı İki Kodun Birleştirilmesi

[iplikci_80]

DATA Sayfası kod bölümündeki, L sütununa girilen plaka rakamları ile T ve W sütunlarındaki plaka numaralarından plaka almaya ve A4 hücresinden itibaren girilen görev yeri kodlarıyla birlikte B4:Q4 arsına kenarlık oluşturma ve B4:Q4 arsındaki formüllü hücrelerdeki formülleri aşağı doğru eklemeye yarayan farklı iki kodun birleştirilmesi hususunda yardımlarınızı rica ediyorum.

 

[Muzaffer Ali]

Merhaba.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Bul As Range
    Dim Son As Long, ilk As Long, s As Long
    Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False: Application.EnableEvents = False
    
    Son = Cells(Rows.Count, 1).End(3).Row + 1
    Range("B4:Q" & Rows.Count).Borders.LineStyle = xlNone
    Range("B4:Q4").Borders(xlEdgeTop).LineStyle = xlDouble
    Range("B4:Q" & Son).Borders(xlInsideHorizontal).LineStyle = xlDot
    Range("B4:Q" & Son).Borders(xlInsideVertical).LineStyle = xlDot
    Range("B4:B" & Son).Borders(xlEdgeLeft).LineStyle = xlDouble
    Range("N4:Q" & Son).Borders(xlEdgeRight).LineStyle = xlDouble
    Range("B" & Son & ":Q" & Son).Borders(xlEdgeBottom).LineStyle = xlDouble
    If Target.Column = 1 Then
        ilk = Range(Split(Target.Address(0, 0), ":")(0)).Row
        For s = 1 To Target.Rows.Count
            Range("B4:Q4").Copy: Range("B" & ilk + s - 1 & ":P" & ilk + s - 1).PasteSpecial Paste:=xlPasteFormulas
        Next
    ElseIf Not Intersect(Target, Range("L:L")) Is Nothing Then
        If Target.Value <> "" Then
            Set Bul = Range("T:T,W:W").Find("*" & Target.Value, , , xlPart)
            If Not Bul Is Nothing Then
                Target.Value = Bul.Value
            End If
        End If
    End If
    
    Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True: Application.EnableEvents = True
End Sub

 

[iplikci_80]

Çok teşekkür ederim.

 

[iplikci_80]

EK' te ekran görüntüsünü paylaştığım hatayla karşılaştım. Bu hususta yardımlarınızı rica ediyorum.

 

[Muzaffer Ali]

Kodu yeniledim. Tekrar deneyin.

 

[iplikci_80]

Cevap2 de verdiğiniz kodu EK'te çalışmanın DATA sayfasına uyarlama hususunda yardımlarınızı rica ediyorum.