şablona veri aktarma

[bydogannn67]

merhabalar,

sayfa 1 deki personel listesindekileri sayfa 2 deki şablon üzerindeki yerlerine makro ile şansımız aktarma varmıdır arkadaslar uzun bi listem var ve patron bunları tek tek şablon halinde istiyo benden yardımcı olabılırsenız sevınırım

fikir verseniz bile olur

 

[mancubus]

merhaba.

Sayfa1 sayfasının ismini Personel_Liste, Sayfa2'nin ismini ise Personel_Detay olarak değiştirdim. yerlerine farklı isim kullanmak isterseniz makroda da bu sayfa isimlerinin geçriği yerleri de bu değişikliğe uygun hale getirmeniz gerekecek.

bilgi verilmediği için, istenilen formattaki tarih alanlarına C sütunundaki alanları getirdim.

ekteki dosyayı inceleyiniz.

Sub xlTR_t153799_Personel_Listeden_Personel_Odeme_Detay()
'http://www.excel.web.tr/f48/ablona-veri-aktarma-t153799.html

    Dim cl As Range, bul As Range
    Dim i As Long, j As Long, sat As Long, calc As Long
    Dim personel
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        calc = .Calculation
        .Calculation = xlCalculationAutomatic
    End With
    
    Worksheets("Personel_Detay").Cells.Clear
    
    Worksheets("Personel_Liste").Copy After:=Worksheets(Worksheets.Count)
    ActiveSheet.UsedRange.RemoveSubtotal
    
    With CreateObject("Scripting.Dictionary")
        For Each cl In ActiveSheet.UsedRange.Columns(1).Offset(1).SpecialCells(2)
            y = .Item(cl.Value)
        Next
        personel = .Keys
    End With
    
    With ActiveSheet
        For i = LBound(personel) To UBound(personel)
            .Cells(1).AutoFilter Field:=1, Criteria1:=personel(i)
            Worksheets("şablon").Range("A1").Value = personel(i)
            For j = 2 To 4
                Set bul = .AutoFilter.Range.Offset(1).SpecialCells(12).Columns(2).Find(Worksheets("şablon").Range("A" & j).Value)
                If Not bul Is Nothing Then
                    sat = bul.Row
                    Worksheets("şablon").Range("B" & j).Value = .Range("C" & sat).Value
                    Worksheets("şablon").Range("C" & j).Value = .Range("M" & sat).Value
                    Worksheets("şablon").Range("D" & j).Value = .Range("C" & sat).Value
                    Worksheets("şablon").Range("E" & j).Value = .Range("L" & sat).Value
                End If
            Next j
            .UsedRange.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            Worksheets("şablon").Range("A1:E6").Copy Worksheets("Personel_Detay").Range("A" & Rows.Count).End(xlUp).Offset(5)
            Worksheets("şablon").Range("B2:E4").ClearContents
        Next i
        .Delete
    End With

    Worksheets("Personel_Detay").Rows("1:4").Delete
    With Worksheets("şablon")
        .Range("A1").ClearContents
        .Range("B2:E4").ClearContents
    End With
    
    With Application
        .EnableEvents = True
        .Calculation = calc
    End With

End Sub

 

[bydogannn67]

çok süper bi çalışma olmuş teşekkürler

 

[mancubus]

rica ederim.
kolay gelsin.