Bir sayfadaki verilerin bazı kolonlarını sıraları değişik olarak başka bir sayfaya hücre biçimi ile aktarmak

[khthonik]

Merhabalar,

kullanmakta olduğum alttaki kod satır sayım fazlalaştığından dolayı kasmakta ve işlem süresi çok uzun olmaktadır. Daha pratik ve hücre biçimini (kenarlık, sayı, metin yada tarih vb) de alan koda ihtiyacım vardır.

Sub ekle()
Dim ws1, ws2 As Worksheet
Dim sonhucre, son As Long

Application.ScreenUpdating = False
Application.EnableEvents = False
ActiveSheet.Unprotect Password:="EYS"

    Set ws1 = Sheets("IRSDKM")
    Set ws2 = Sheets("DKM")
    
    ws2.Range("A3:O65536").ClearContents

sonhucre = ws1.Range("C65536").End(xlUp).Row

For i = 3 To sonhucre
son = ws2.Cells(Rows.Count, "C").End(3).Row + 1

    ws2.Cells(son, 1) = ws1.Cells(i, 1) 'SIRA
    ws2.Cells(son, 2) = ws1.Cells(i, 2)  'Talep no
    ws2.Cells(son, 3) = ws1.Cells(i, 3)  'Proje
    ws2.Cells(son, 4) = ws1.Cells(i, 4)  'Talebi Yapan
    ws2.Cells(son, 5) = ws1.Cells(i, 5)  'Talep Onay
    ws2.Cells(son, 6) = ws1.Cells(i, 6)  'Talep Tarihi
    ws2.Cells(son, 7) = ws1.Cells(i, 7)  'İstenen Teslim Tarihi
    ws2.Cells(son, 8) = ws1.Cells(i, 8)  'Bütçe Kodu
    ws2.Cells(son, 9) = ws1.Cells(i, 9)  'Talep Edilen Malzeme
    ws2.Cells(son, 10) = ws1.Cells(i, 10)  'Detay (Marka Model vb
    ws2.Cells(son, 11) = ws1.Cells(i, 11)  'Birim
    ws2.Cells(son, 12) = ws1.Cells(i, 12)  'Talep Miktarı
    ws2.Cells(son, 13) = ws1.Cells(i, 18)  'İlgili Kısım
    ws2.Cells(son, 14) = ws1.Cells(i, 62)  'Teslim Durumu
    ws2.Cells(son, 15) = ws1.Cells(i, 87)  'Teslim Miktarı

Next i

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True, Password:="EYS"
Application.EnableEvents = False
Application.EnableEvents = True

End Sub

Saygılar..

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub ekle()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim sonhucre As Long, son As Long
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    ActiveSheet.Unprotect Password:="EYS"
    
    Set ws1 = Sheets("IRSDKM")
    Set ws2 = Sheets("DKM")
    
    ws2.Range("A3:O65536").ClearContents
    
    sonhucre = ws1.Range("C65536").End(xlUp).Row
    son = ws2.Cells(Rows.Count, "C").End(3).Row + 1
    
    ws1.Range("A3:L" & sonhucre).Copy ws2.Range("A" & son)
    ws1.Range("R3:R" & sonhucre).Copy ws2.Range("M" & son)
    ws1.Range("BJ3:BJ" & sonhucre).Copy ws2.Range("N" & son)
    ws1.Range("CI3:CI" & sonhucre).Copy ws2.Range("O" & son)
    
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True, Password:="EYS"
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[khthonik]

Korhan Bey,
Teşekkür ederim. Gayet hızlı bir şekilde çalıştı. Fakat taşıdığımız hücrelerdeki verileri değer olarak aktarmasını istiyorum. Kod da nasıl bir değişiklik yapmak gerekmektedir. Yardımcı olur musunuz?
Saygılar..

 

[Korhan Ayhan]

Aşağıdaki gibi deneyiniz.

Option Explicit

Sub ekle()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim sonhucre As Long, son As Long
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    ActiveSheet.Unprotect Password:="EYS"
    
    Set ws1 = Sheets("IRSDKM")
    Set ws2 = Sheets("DKM")
    
    ws2.Range("A3:O65536").ClearContents
    
    sonhucre = ws1.Range("C65536").End(xlUp).Row
    son = ws2.Cells(Rows.Count, "C").End(3).Row + 1
    
    ws1.Range("A3:L" & sonhucre).Copy
    ws2.Range("A" & son).PasteSpecial xlPasteFormats
    ws2.Range("A" & son).PasteSpecial xlPasteValues
    
    ws1.Range("R3:R" & sonhucre).Copy
    ws2.Range("M" & son).PasteSpecial xlPasteFormats
    ws2.Range("M" & son).PasteSpecial xlPasteValues
    
    ws1.Range("BJ3:BJ" & sonhucre).Copy
    ws2.Range("N" & son).PasteSpecial xlPasteFormats
    ws2.Range("N" & son).PasteSpecial xlPasteValues
    
    ws1.Range("CI3:CI" & sonhucre).Copy
    ws2.Range("O" & son).PasteSpecial xlPasteFormats
    ws2.Range("O" & son).PasteSpecial xlPasteValues
        
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True, Password:="EYS"
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[khthonik]

Korhan Bey,
Emeğinize sağlık, teşekkür ederim.
Saygılar..