Sayfalar Arası Veri Aktarma Sıralı

[Yaren Eslem]

Merhabalar Selamlar... Ekteki örnek dosyamda istenilen; sayfa 1'de bulunan değişken değerlerin sayfa 2'ye sıralı bir vaziyette aktarılmasıdır. Aktar butonu ile sadece 3 - 4 Satır ekleyebiliyorum, her defasında sayfa 1 ilk dört değeri baz alıyor (Almaması gerek) Çünkü değerler değiştikçe sayfa 2'ye sıralı gitmesi gerekiyor... Yardım lütfen



Örnek Dosya

 

[Yaren Eslem]

(Sıralı derken; Sayfa 2'Ye Tarih sıralı değil bu arada, sadece alt alta aktarsa yeterli)

 

[numan şamil]

Merhaba
Dediğinizi pek anlamadım ancak
Aşağıdaki kodları bir dene belki bir fikir verebilir
Sub Aktar()
Dim SON As Long
Dim S1, S2 As Worksheet
Set S1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")
Satır = 2
SON = S1.Cells(Rows.Count, 3).End(3).Row
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
S2.Range("A1:E1048576") = ""
For x = 2 To SON
If S1.Range("C" & x).Value <> "" Then
S2.Range("A" & Satır).Value = S1.Range("C" & x).Value
S2.Range("B" & Satır).Value = S1.Range("D" & x).Value
S2.Range("C" & Satır).Value = S1.Range("E" & x).Value
S2.Range("D" & Satır).Value = S1.Range("F" & x).Value
S2.Range("E" & Satır).Value = S1.Range("G" & x).Value
Satır = Satır + 1
End If
Next x
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

 

[YUSUF44]

Aşağıdaki gibi deneyin:

Sub Aktar()

Dim SON As Long

Sheets("Sayfa1").Unprotect
ActiveSheet.Unprotect
taksit = Sheets("Sayfa1").[B2] + 1
yeni = Sheets("Sayfa2").Cells(Rows.Count, "A").End(3).Row + 1
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


Sheets("Sayfa1").Range("C2:G" & taksit).Copy: Sheets("Sayfa2").Cells(yeni, "A").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

 

[Yaren Eslem]

Teşekkürlerrr, Allah Sizlerden Razı olsun inşALLAH...