eklemiş olduğum örnekte mevcut bir makro var fakat örnekte açıkladığım gibi iki farklı sutunu taratıp veri aktaramıyorum
bilgisi olanlar yardı edebilir mi
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim S1 As Worksheet, STR As Long
Set S1 = Sheets(Cells(Target.Row, "A").Text)
Application.EnableEvents = False
Application.ScreenUpdating = False
If Target.Column = 3 Then
If Intersect(Target, Range("C:C")) Is Nothing Then _
Application.ScreenUpdating = True: Application.EnableEvents = True: _
Exit Sub
STR = S1.Range("B" & Rows.Count).End(xlUp).Row + 1
S1.Cells(STR, "B") = Target
ElseIf Target.Column = 5 Then
If Intersect(Target, Range("E:E")) Is Nothing Then _
Application.ScreenUpdating = True: Application.EnableEvents = True: _
Exit Sub
STR = S1.Range("A" & Rows.Count).End(xlUp).Row + 1
S1.Cells(STR, "A") = Target
ElseIf Target.Column = 6 Then
If Intersect(Target, Range("F:F")) Is Nothing Then _
Application.ScreenUpdating = True: Application.EnableEvents = True: _
Exit Sub
STR = S1.Range("C" & Rows.Count).End(xlUp).Row + 1
S1.Cells(STR, "C") = Target
Else
Set S1 = Sheets(Cells(Target.Row, "K").Text)
Application.EnableEvents = False
Application.ScreenUpdating = False
If Target.Column = 9 Then
If Intersect(Target, Range("I:I")) Is Nothing Then _
Application.ScreenUpdating = True: Application.EnableEvents = True: _
Exit Sub
STR = S1.Range("I" & Rows.Count).End(xlUp).Row + 1
S1.Cells(STR, "I") = Target
ElseIf Target.Column = 4 Then
If Intersect(Target, Range("D
")) Is Nothing Then _
Application.ScreenUpdating = True: Application.EnableEvents = True: _
Exit Sub
STR = S1.Range("H" & Rows.Count).End(xlUp).Row + 1
S1.Cells(STR, "H") = Target
ElseIf Target.Column = 10 Then
If Intersect(Target, Range("J:J")) Is Nothing Then _
Application.ScreenUpdating = True: Application.EnableEvents = True: _
Exit Sub
STR = S1.Range("J" & Rows.Count).End(xlUp).Row + 1
S1.Cells(STR, "J") = Target[/COLOR]End If
Application.ScreenUpdating = True: Application.EnableEvents = True
End Sub
bilgisi olanlar yardı edebilir mi
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim S1 As Worksheet, STR As Long
Set S1 = Sheets(Cells(Target.Row, "A").Text)
Application.EnableEvents = False
Application.ScreenUpdating = False
If Target.Column = 3 Then
If Intersect(Target, Range("C:C")) Is Nothing Then _
Application.ScreenUpdating = True: Application.EnableEvents = True: _
Exit Sub
STR = S1.Range("B" & Rows.Count).End(xlUp).Row + 1
S1.Cells(STR, "B") = Target
ElseIf Target.Column = 5 Then
If Intersect(Target, Range("E:E")) Is Nothing Then _
Application.ScreenUpdating = True: Application.EnableEvents = True: _
Exit Sub
STR = S1.Range("A" & Rows.Count).End(xlUp).Row + 1
S1.Cells(STR, "A") = Target
ElseIf Target.Column = 6 Then
If Intersect(Target, Range("F:F")) Is Nothing Then _
Application.ScreenUpdating = True: Application.EnableEvents = True: _
Exit Sub
STR = S1.Range("C" & Rows.Count).End(xlUp).Row + 1
S1.Cells(STR, "C") = Target
Else
Set S1 = Sheets(Cells(Target.Row, "K").Text)
Application.EnableEvents = False
Application.ScreenUpdating = False
If Target.Column = 9 Then
If Intersect(Target, Range("I:I")) Is Nothing Then _
Application.ScreenUpdating = True: Application.EnableEvents = True: _
Exit Sub
STR = S1.Range("I" & Rows.Count).End(xlUp).Row + 1
S1.Cells(STR, "I") = Target
ElseIf Target.Column = 4 Then
If Intersect(Target, Range("D
Application.ScreenUpdating = True: Application.EnableEvents = True: _
Exit Sub
STR = S1.Range("H" & Rows.Count).End(xlUp).Row + 1
S1.Cells(STR, "H") = Target
ElseIf Target.Column = 10 Then
If Intersect(Target, Range("J:J")) Is Nothing Then _
Application.ScreenUpdating = True: Application.EnableEvents = True: _
Exit Sub
STR = S1.Range("J" & Rows.Count).End(xlUp).Row + 1
S1.Cells(STR, "J") = Target[/COLOR]End If
Application.ScreenUpdating = True: Application.EnableEvents = True
End Sub
Ekli dosyalar
Son düzenleme:
