Referans sayfaya göre sayfa kopyalama ve adlandırma

[ockucukay]

Merhaba,
Sorunumu ekli dosyada detaylı olarak anlattım. Kısaca özetlemek gerekirse, kullandığım iki makro var ve iki makroyu şöyle birleştirmek istiyorum. Makroyu çalıştırdığımda, önce bugünün tarihiyle yeni bir box no sayfası açacak. Daha sonra açtığım bu box no sayfasını referans alıp (günün tarihine göre değişken) o sayfada yazılı kutu adedi kadar sayfa açacak. açılan sayfa numaraları birbirini takip edecek, yani tekrar eden numara olmayacak.
Yardımcı olacak arkadaşlarıma şimdiden teşekkür ederim.

 

[nsertoglu]

Sub KopyalaTarih()
'Sheets("Sayfa1").Visible = True
ActiveSheet.Select
ActiveSheet.Copy After:=Worksheets(Worksheets.Count)
10 NewPageName = InputBox("Kopyalamak Üzere Oldugunuz Sayfanin Adini Belirleyiniz...!!!")
For a = 1 To Sheets.Count
If UCase(Sheets(a).Name) = UCase(NewPageName) Then
MsgBox "Seçtiginiz sayfa adi mevcuttur yeniden deneyin."
GoTo 10
End If
Next
ActiveWindow.ActiveSheet.Name = NewPageName
' * aşağıdaki kodları ekleyin ve deneyin * nsertoglu *
Cells(Rows.Count, "a").Select
sonR = Selection.End(xlUp).Row
For r = 2 To sonR
Call Kopyala
Next r
End Sub

 

[ockucukay]

çalışmadı malesef, sürekli referans sayfayı kopyalıyor. ilginize teşekkür ederim.

 

[nsertoglu]

makronun çalışmaması

Sizin ikinci kodunuz da aynı işlemi yapıyor şeklinde görmüştüm;
yapacağınız tek aktivite var: istediğiniz 2nci işlemi yapan bir kod yazın ve onu birinciden "call" komutu ile çağıran for next döngüsünün içine yazın ...

"Zorlanmayan KAS GELİŞMEZ" der Atalarımız..

 

[ockucukay]

Sizin ikinci kodunuz da aynı işlemi yapıyor şeklinde görmüştüm;
yapacağınız tek aktivite var: istediğiniz 2nci işlemi yapan bir kod yazın ve onu birinciden "call" komutu ile çağıran for next döngüsünün içine yazın ...

"Zorlanmayan KAS GELİŞMEZ" der Atalarımız..

Bende denemiştim zaten. kaslarımı zorluyorum yani . Yapamadığım şey, referans sayfa her seferinde farklı tarihte oluyor, yani sabit bir ismi yok. Rapor numaralarının da birbirini takip etmesi gerekli. Benim yapamadığım referans sayfayı seçtirmek. Onu yapabilsem diğer kısmını zaten yapabilirim. Sizden ricam referans sayfayı seçtirme konusunda yardımcı olmanız. İlginize tekrar teşekkür ederim.

 

[ockucukay]

güncelleme...

 

[ockucukay]

Merhaba

Dosyayı ekteki hale getirdim, ancak bir döngüye sokamadım. Döngüye sokamadığım için Target Value değişmiyor ve aynı isimde ikinci bir sayfa açmaya çalışıyor. Yardımlarınızı bekliyorum.

Private Sub Workbook_SheetBeforeDoubleClick(ByVal sh As Object, ByVal Target As Range, Cancel As Boolean)
On Error GoTo Son
Dim Sayfa As String
Dim SUT As Integer

If ActiveSheet.Name <> "Sevk Listesi" Then
Sheets("Sevk Listesi").Select
Else
Sayfa = Target.Value
If Sayfa <> "" Then Sheets(Sayfa).Select
End If
Exit Sub
Son:
If Intersect(Target, Sheets("Sevk Listesi").Range("A2:A65536")) Is Nothing Then Exit Sub
Sordum = MsgBox(Target.Value & " Adlı Sayfa Ekleniyor", vbYesNo, "Rapor")
If Sordum = vbYes Then
For SUT = 1 To 50
Sheets("Sablon").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = Target.Value
'MsgBox Target.Value & " Sayfası Açıldı", vbOKOnly, "Rapor"
Next
End If
End Sub

 

[ockucukay]

Merhaba

Kodu aşağıdaki hale getirdim. Bu seferde yeni sayfa eklediğim zaman işlemi gerçekleştirmiyor. Yardım edebilecek olan var mı acaba?

Bir ikinci konu; bu kod ilgili sayfada çift tıklama yapılınca çalışıyor, bunu bir buton yardımıyla nasıl yaparız?

Private Sub Workbook_SheetBeforeDoubleClick(ByVal sh As Object, ByVal Target As Range, Cancel As Boolean)
On Error GoTo Son
Dim Sayfa As String

If ActiveSheet.Name <> "Sevk Listesi" Then
Sheets("Sevk Listesi").Select
Else
Sayfa = Target.Value
If Sayfa <> "" Then Sheets(Sayfa).Select
End If
Exit Sub
Son:
If Intersect(Target, Sheets("Sevk Listesi").Range("A2:A65536")) Is Nothing Then Exit Sub
Sordum = MsgBox(Target.Value & " Adlı Sayfa Ekleniyor", vbYesNo, "Rapor")
If Sordum = vbYes Then
On Error Resume Next
For i = 2 To Range("A65536").End(3).Row
Sheets("Sablon").Copy After:=Sheets(Sheets.Count)
10 Sheets(Sheets.Count).Name = Sheets("Sevk Listesi").Range("A" & i)
If UCase(Sheets(a).Name) = UCase(NewPageName) Then
MsgBox "Seçtiginiz sayfa adi mevcuttur yeniden deneyin."
GoTo 10
End If
Next
End If
End Sub

 

[ockucukay]

Arkadaşlar yardımcı olabilecek kimse varmı acaba?

Merhaba

Kodu aşağıdaki hale getirdim. Bu seferde yeni sayfa eklediğim zaman işlemi gerçekleştirmiyor. Yardım edebilecek olan var mı acaba?

Bir ikinci konu; bu kod ilgili sayfada çift tıklama yapılınca çalışıyor, bunu bir buton yardımıyla nasıl yaparız?

Private Sub Workbook_SheetBeforeDoubleClick(ByVal sh As Object, ByVal Target As Range, Cancel As Boolean)
On Error GoTo Son
Dim Sayfa As String

If ActiveSheet.Name <> "Sevk Listesi" Then
Sheets("Sevk Listesi").Select
Else
Sayfa = Target.Value
If Sayfa <> "" Then Sheets(Sayfa).Select
End If
Exit Sub
Son:
If Intersect(Target, Sheets("Sevk Listesi").Range("A2:A65536")) Is Nothing Then Exit Sub
Sordum = MsgBox(Target.Value & " Adlı Sayfa Ekleniyor", vbYesNo, "Rapor")
If Sordum = vbYes Then
On Error Resume Next
For i = 2 To Range("A65536").End(3).Row
Sheets("Sablon").Copy After:=Sheets(Sheets.Count)
10 Sheets(Sheets.Count).Name = Sheets("Sevk Listesi").Range("A" & i)
If UCase(Sheets(a).Name) = UCase(NewPageName) Then
MsgBox "Seçtiginiz sayfa adi mevcuttur yeniden deneyin."
GoTo 10
End If
Next
End If
End Sub

 

[ockucukay]

güncelleme...

Arkadaşlar yardımcı olabilecek kimse varmı acaba?

 

[ockucukay]

Merhaba arkadaşlar

Aşağıdaki kodla problem çözüldü. Belki başka arkadaşlara yardımı olur diye kodu veriyorum.

Sub Sayfa_Ekle()

Dim blnfound As Boolean
Dim i As Integer
Dim ws As Object
Dim strListSheet As String: strListSheet = "Sevk Listesi" 'Bütün listenin olduğu ana sayfa.

For i = 2 To Sheets(strListSheet).Cells(Rows.Count, 1).End(xlUp).Row
blnfound = False
For Each ws In ThisWorkbook.Worksheets
If UCase(ws.Name) = UCase(CStr(Sheets(strListSheet).Cells(i, 1).Value)) Then blnfound = True
Next ws
If blnfound = False Then
Sheets("Sablon").Copy After:=Sheets(Worksheets.Count) 'Kopyalanan şablon sayfası
ActiveSheet.Name = Sheets(strListSheet).Cells(i, 1).Value
End If
Next i

End Sub