Makro Tekrarlanan işlemleri Seriye Bağlama.

[AhmetGuven]

Merhaba,

Aşağıdaki Makro için daha kolay bir seri var mı arkadaşlar.

Sub Click1()
Application.ScreenUpdating = False
Dim answer As Integer
answer = MsgBox("Doğru Tarihe İşlem Yaptığınıza Emin misin?", vbYesNo + vbQuestion, "İşlem Hakkında!")
If answer = vbYes Then
'---1--- BAŞLA
Sheets("Deneme").Select
Range("A1").Select
On Error Resume Next
Range(Worksheets("Sayfa1").Range("D3").Text).Select
Worksheets("Sayfa1").Range("F3").Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Sheets("Sayfa1").Select
Application.CutCopyMode = False
On Error GoTo 0
'---1--- SON
'---2--- BAŞLA
Sheets("Deneme").Select
Range("A1").Select
On Error Resume Next
Range(Worksheets("Sayfa1").Range("D4").Text).Select
Worksheets("Sayfa1").Range("F4").Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Sheets("Sayfa1").Select
Application.CutCopyMode = False
On Error GoTo 0
'---2--- SON
'---3--- BAŞLA
Sheets("Deneme").Select
Range("A1").Select
On Error Resume Next
Range(Worksheets("Sayfa1").Range("D5").Text).Select
Worksheets("Sayfa1").Range("F5").Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Sheets("Sayfa1").Select
Application.CutCopyMode = False
On Error GoTo 0
'---3--- SON
'---4--- BAŞLA
Sheets("Deneme").Select
Range("A1").Select
On Error Resume Next
Range(Worksheets("Sayfa1").Range("D6").Text).Select
Worksheets("Sayfa1").Range("F6").Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Sheets("Sayfa1").Select
Application.CutCopyMode = False
On Error GoTo 0
'---4--- SON
'---5--- BAŞLA
Sheets("Deneme").Select
Range("A1").Select
On Error Resume Next
Range(Worksheets("Sayfa1").Range("D7").Text).Select
Worksheets("Sayfa1").Range("F7").Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Sheets("Sayfa1").Select
Application.CutCopyMode = False
On Error GoTo 0
'---5--- SON
MsgBox "..::.. EVET Butonuna Basıldı - İşlem Yapıldı. ..::..", vbInformation, "Bilgi !"
Else
MsgBox "..::.. HAYIR Butonuna Basıldı - İşlenmedi. ..::..", vbInformation, "Bilgi !"
End If
Application.ScreenUpdating = True
End Sub

 

[PLİNT]

Merhaba
Yukarıdaki kodlarınız; aşağıdaki gibi düzenlenebilir

[SIZE="2"]Sub Click1()
Application.ScreenUpdating = False
Dim a As Long, answer As Long
Dim s1 As Worksheet, s2 As Worksheet
Dim v As Integer
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Deneme")
answer = MsgBox("Doğru Tarihe İşlem Yaptığınıza Emin misin?", vbYesNo + vbQuestion, "İşlem Hakkında!")
If answer = vbYes Then
On Error Resume Next
For a = 3 To s1.Cells(Rows.Count, "D").End(3).Row
s1.Range("F" & a).Copy
s2.Range(s1.Cells(a, "D").Text).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
If Err <> 0 Then v = v + 1: Err = 0
Next
Application.CutCopyMode = False
MsgBox "..::.. EVET Butonuna Basıldı - İşlem Yapıldı. ..::..", vbInformation, "Bilgi !"
If v <> Empty Then MsgBox v & " Ad.Hatalı işlem atlandı"
Else
MsgBox "..::.. HAYIR Butonuna Basıldı - İşlenmedi. ..::..", vbInformation, "Bilgi !"
End If
Application.ScreenUpdating = True
End Sub[/SIZE]

 

[AhmetGuven]

Merhaba
Yukarıdaki kodlarınız; aşağıdaki gibi düzenlenebilir

[SIZE="2"]Sub Click1()
Application.ScreenUpdating = False
Dim a As Long, answer As Long
Dim s1 As Worksheet, s2 As Worksheet
Dim v As Integer
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Deneme")
answer = MsgBox("Doğru Tarihe İşlem Yaptığınıza Emin misin?", vbYesNo + vbQuestion, "İşlem Hakkında!")
If answer = vbYes Then
On Error Resume Next
For a = 3 To s1.Cells(Rows.Count, "D").End(3).Row
s1.Range("F" & a).Copy
s2.Range(s1.Cells(a, "D").Text).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
If Err <> 0 Then v = v + 1: Err = 0
Next
Application.CutCopyMode = False
MsgBox "..::.. EVET Butonuna Basıldı - İşlem Yapıldı. ..::..", vbInformation, "Bilgi !"
If v <> Empty Then MsgBox v & " Ad.Hatalı işlem atlandı"
Else
MsgBox "..::.. HAYIR Butonuna Basıldı - İşlenmedi. ..::..", vbInformation, "Bilgi !"
End If
Application.ScreenUpdating = True
End Sub[/SIZE]

Teşekkürler.

Tam istediğim gibi. :hihoho: