Aktif Aktarma

[oburs]

Selamlar..
bir araç listesi var ve buradaki departman kolonuna göre diğer departman sekmelerine veriyi benim girdiğim an aktarmasını istemekteyim.
konu hakkında bilgilerinize danışmak isterim..

 

[Murat OSMA]

Bu kodları kullanabilirsiniz..

[FONT="Trebuchet MS"][SIZE="2"]Sub Emre()
    Dim s1 As Worksheet, sh As Worksheet, i&, sayfabulundu As Boolean
    Application.ScreenUpdating = False
    Set s1 = ThisWorkbook.Worksheets("HOME")
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "HOME" Then sh.Rows("2:10000").Delete
    Next sh
    For i = 2 To s1.Rows.Count
        If s1.Cells(i, "I") = "" Then Exit For
        sayfabulundu = False
        For Each sh In ThisWorkbook.Worksheets
            If sh.Name = s1.Range("I" & i).Value Then
                sayfabulundu = True
                s1.Range("A" & i & ":U" & i).Copy
                Sheets(sh.Name).Activate
                ActiveSheet.Range("A655536").End(3)(2, 1).Activate
                ActiveSheet.Paste
            End If
        Next
        If Not sayfabulundu Then
            Set sh = ThisWorkbook.Worksheets.Add(before:=ThisWorkbook.Worksheets("HOME"))
            s1.Range("A1:U1").Copy sh.Range("A1")
            sh.Name = s1.Cells(i, "I").Value
            s1.Range("A" & i & ":U" & i).Copy
            Sheets(sh.Name).Activate
            ActiveSheet.Range("A65536").End(3)(2, 1).Activate
            ActiveSheet.Paste
        End If
    Next i
    Application.ScreenUpdating = True
    i = Empty: Set sh = Nothing: Set s1 = Nothing
End Sub[/SIZE][/FONT]