Kod ile Aktarma İşlemi

[Bakigemlik]

Merhaba,

Aşağıdaki kod ile sayfalara veri aktarıyorum, aktarma işlemi Ana Sayfadan sayfa isimlerine göre yapılıyor, Ana Sayfada B2 den aktarmaya başlıyor ve ilgili sayfanın A2 hücresine veriler akıyor,

Aktarma işleminin A2 değilde A10 dan itibaren aktarılması için nasıl değişiklik yapmam gerekiyor,

Sub aktarr()
Application.ScreenUpdating = False
On Error Resume Next
Set s1 = ThisWorkbook.Worksheets("Ana Dosya")
For i = 2 To s1.Range("A65536").End(xlUp).Row
Set s2 = ThisWorkbook.Worksheets(s1.Cells(i, 1).Value)
If WorksheetFunction.CountIf(s2.Cells.Range("b2:b65536"), s1.Cells(i, "d")) = 0 Then
sonsatir = s2.Range("A65536").End(xlUp).Row + 1
s2.Cells(sonsatir, 2) = s1.Cells(i, 3)
s2.Cells(sonsatir, 1) = s1.Cells(i, 2)
s2.Cells(sonsatir, 3) = s1.Cells(i, 6)
s2.Cells(sonsatir, 4) = s1.Cells(i, 10)
s2.Cells(sonsatir, 5) = s1.Cells(i, 32)
s2.Cells(sonsatir, 6) = s1.Cells(i, 11)
s2.Cells(sonsatir, 7) = s1.Cells(i, 12)
s2.Cells(sonsatir, 8) = s1.Cells(i, 13)
s2.Cells(sonsatir, 14) = s1.Cells(i, 36)
s2.Cells(sonsatir, 15) = s1.Cells(i, 21)
s2.Cells(sonsatir, 13) = s1.Cells(i, 35)
s2.Cells(sonsatir, 9) = s1.Cells(i, 34)

End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem TAMAM.", vbInformation
End Sub

 

[Vedat Özer]

Selamlar,

For i = 2 To s1.Range("A65536").End(xlUp).Row


Değerini değiştirerek deneyiniz.

 

[Bakigemlik]

Merhaba,

o kısımda aşağıdaki gibi değişiklik yaptım ama sonuç vermedi

For i = 5 To s1.Range("A65536").End(xlUp).Row

 

[PLİNT]

Merhaba
Birde aşağıdaki gibi kırmızı bölümü ekleyerek denermisiniz?

 If WorksheetFunction.CountIf(s2.Cells.Range("b2:b65536"), s1.Cells(i, "d")) = 0 Then
sonsatir = s2.Range("A65536").End(xlUp).Row + 1
[COLOR="Red"]If sonsatir < 10 Then sonsatir = 10[/COLOR]
s2.Cells(sonsatir, 2) = s1.Cells(i, 3)
s2.Cells(sonsatir, 1) = s1.Cells(i, 2)

 

[Bakigemlik]

Sayın PLINT desteğiniz için çok teşekkürler,

 

[Bakigemlik]

Merhaba
Birde aşağıdaki gibi kırmızı bölümü ekleyerek denermisiniz?

 If WorksheetFunction.CountIf(s2.Cells.Range("b2:b65536"), s1.Cells(i, "d")) = 0 Then
sonsatir = s2.Range("A65536").End(xlUp).Row + 1
[COLOR="Red"]If sonsatir < 10 Then sonsatir = 10[/COLOR]
s2.Cells(sonsatir, 2) = s1.Cells(i, 3)
s2.Cells(sonsatir, 1) = s1.Cells(i, 2)

Merhaba,

Bu koda aşağıdaki formülü nasıl ekleyebilirim,

bir çok formül ekleyeceğim bu konuda destek olursanız diğerlerini uyarlayabilirim,

Bununla beraber MsgBox "İşlem TAMAM.", vbInformation bu mesajın kodun çalışma süresini ölçüp vermesi mümkün mü örnek "03:11 dk işlem tamam"

,

= "=IFERROR(AM2+AH2+L2,"""")"

Teşekkürler

 

[PLİNT]

Merhaba
Kodlarınıza aşağıdaki gibi eklemeler yaparak deneyin.
(mavi ile belirtilen "C" sütununu; verilerin göderileceği sayfada formülün ekleneceği sütun adı ile değiştiriniz.)

Sub aktarr()
[COLOR="Red"]s = Now
Application.Calculation = False[/COLOR]
Application.ScreenUpdating = False
On Error Resume Next
'..............
'...............
s2.Cells(sonsatir, 9) = s1.Cells(i, 34)
[COLOR="Red"]s2.Cells(sonsatir, [COLOR="Blue"]"C"[/COLOR]).FormulaLocal = "=IFERROR(AM" & sonsatir & "+AH" & sonsatir & "+L" & sonsatir & ";"""")"[/COLOR]
End If
Next i
Application.ScreenUpdating = True
[COLOR="Red"]Application.Calculation = True
s2 = Now
MsgBox Right(FormatDateTime(s2 - s, vbLongTime), 5) & "  Dk. İşlem Tamam", vbInformation[/COLOR]
End Sub

 

[Bakigemlik]

Merhaba
Kodlarınıza aşağıdaki gibi eklemeler yaparak deneyin.
(mavi ile belirtilen "C" sütununu; verilerin göderileceği sayfada formülün ekleneceği sütun adı ile değiştiriniz.)

Sub aktarr()
[COLOR="Red"]s = Now
Application.Calculation = False[/COLOR]
Application.ScreenUpdating = False
On Error Resume Next
'..............
'...............
s2.Cells(sonsatir, 9) = s1.Cells(i, 34)
[COLOR="Red"]s2.Cells(sonsatir, [COLOR="Blue"]"C"[/COLOR]).FormulaLocal = "=IFERROR(AM" & sonsatir & "+AH" & sonsatir & "+L" & sonsatir & ";"""")"[/COLOR]
End If
Next i
Application.ScreenUpdating = True
[COLOR="Red"]Application.Calculation = True
s2 = Now
MsgBox Right(FormatDateTime(s2 - s, vbLongTime), 5) & "  Dk. İşlem Tamam", vbInformation[/COLOR]
End Sub

Sayın Plint desteğiniz için öncelikle teşekkürler,

Formülün S1. Ana Sayfa'da çalışması gerekiyor, bunun için nasıl işlem yapabilirim,

Teşekkürler,