• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

kod hata veriyor

Katılım
20 Şubat 2012
Mesajlar
150
Excel Vers. ve Dili
2007 türkçe
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: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
 

Ekli dosyalar

Son düzenleme:
yok mu fikri olan
 
Geri
Üst