Sayfa Adını Getir

[ZorBey_]

Merhaba İyi Çalışmalar
Mevcut Olan Kod İki Tarih Arasında Seçilen Sayfadan Seçileni Getiriyor.Yapmak İstediğim Mevcut Kod'a İlave Olarak Seçim Yapılınca Hangi Sayfa Seçildiyse O Sayfa İsiminin Yeşil Alanda C5 Sutunundan İtibaren Yazılması
Teşekkür Ederim İyi Çalışmalar.

 

[asi_kral]

Merhaba
Kod kime ait bilmiyorum ama oldukça seri bir kod olmuş

Private Sub CommandButton4_Click()
'SEÇİLEN İKİ TARİH ARASINDAKİ İSMİ GETİRİR
Call Makro1
Dim i       As Long, _
Sat     As Long, _
Adet    As Long, _
s1      As Worksheet, _
s2      As Worksheet, _
ara   As String, _
BasTar  As Date, _
BitTar  As Date

Set s1 = Sheets(Range("E3").Text)
Set s2 = Sheets("Ara")
s2.Select
BasTar = Range("D2")
BitTar = Range("D3")
ara = Range("E2")
    
Sat = Cells(Rows.Count, "C").End(3).Row
Application.ScreenUpdating = False
For i = 2 To s1.Cells(Rows.Count, "C").End(3).Row
If s1.Cells(i, "D") >= BasTar And s1.Cells(i, "D") <= BitTar And s1.Cells(i, "F") = ara Then
Sat = Sat + 1
Adet = Adet + 1
s1.Range("C" & i & ":AB" & i).Copy Cells(Sat, "D")
End If
Next i
Application.ScreenUpdating = True
If Adet = 0 Then
MsgBox "Koşula Göre Aktarılacak Bilgi Bulamadım....", vbInformation, "N. YEŞERTENER --> www.excel.web.tr"
Else
[COLOR="Red"]s2.Range("C5:C" & Sat) = s2.Range("E2")[/COLOR]
MsgBox Adet & " Adet Koşula Uyan Kayıt Aktarılmıştır...", vbInformation, "N. YEŞERTENER --> www.excel.web.tr"
End If
End Sub

Kırmızı olan bölüm eklenmiştir.

 

[SEMAY77]

Aşağıdaki kodu komple kopyalayıp eski kodun üstüne yapıştırın.

İyi çalışmalar!

Private Sub CommandButton4_Click()
'SEÇİLEN İKİ TARİH ARASINDAKİ İSMİ GETİRİR
Call Makro1
Dim i As Long, _
Sat As Long, _
Adet As Long, _
s1 As Worksheet, _
s2 As Worksheet, _
ara As String, _
BasTar As Date, _
BitTar As Date

Set s1 = Sheets(Range("E3").Text)
Set s2 = Sheets("Ara")
s2.Select
BasTar = Range("D2")
BitTar = Range("D3")
ara = Range("E2")
sayfa = Cells(3, 5)

Sat = Cells(Rows.Count, "C").End(3).Row
Application.ScreenUpdating = False
For i = 2 To s1.Cells(Rows.Count, "C").End(3).Row
If s1.Cells(i, "D") >= BasTar And s1.Cells(i, "D") <= BitTar And s1.Cells(i, "F") = ara Then
Sat = Sat + 1
Adet = Adet + 1
s1.Range("C" & i & ":AB" & i).Copy Cells(Sat, "D")
Cells(Sat, 3) = sayfa
End If
Next i
Application.ScreenUpdating = True
If Adet = 0 Then
MsgBox "Koşula Göre Aktarılacak Bilgi Bulamadım....", vbInformation, "N. YEŞERTENER --> www.excel.web.tr"
Else
MsgBox Adet & " Adet Koşula Uyan Kayıt Aktarılmıştır...", vbInformation, "N. YEŞERTENER --> www.excel.web.tr"
End If

End Sub