Sayfa Adını Hücreye yazdırmak (ekli makroya ilave)

[netkit]

Merhaba;
Forumdan aldığım bu kod ile Kitaptaki sayfaların özeti DATA sayfasına geliyor. Fakat hangi ürünlerin hangi sayfalardan geldiğini görmek için yandaki kolonada sayfa isimlerini yazdırmak istiyorum.
ActiveSheet.Name denedim olmadı. Acaba koda nasıl bir ekleme yapmak gerekiyor?

Sub Consolidate_All_Sheets()
    Dim Sayfa As Worksheet, S1 As Worksheet
   
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("DATA").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
   
    Set S1 = Sheets.Add(, Sheets(Sheets.Count))
    S1.Name = "DATA"
   
    For Each Sayfa In ThisWorkbook.Worksheets
        If Sayfa.Name <> "DATA" Then
            If S1.Range("A1") = "" Then Sayfa.Range("A1:B1").Copy S1.Range("A1")
            Sayfa.Range("A2:B" & Sayfa.Cells(Sayfa.Rows.Count, 1).End(3).Row).Copy S1.Cells(S1.Rows.Count, 1).End(3)(2, 1)
        End If
    Next

    S1.Columns.AutoFit

    Set S1 = Nothing
   
    MsgBox "Sayfalar konsolide edilmiştir.", vbInformation
End Sub

 

[baydeniro]

Merhaba;
Forumdan aldığım bu kod ile Kitaptaki sayfaların özeti DATA sayfasına geliyor. Fakat hangi ürünlerin hangi sayfalardan geldiğini görmek için yandaki kolonada sayfa isimlerini yazdırmak istiyorum.
ActiveSheet.Name denedim olmadı. Acaba koda nasıl bir ekleme yapmak gerekiyor?

Sub Consolidate_All_Sheets()
    Dim Sayfa As Worksheet, S1 As Worksheet
  
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("DATA").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
  
    Set S1 = Sheets.Add(, Sheets(Sheets.Count))
    S1.Name = "DATA"
  
    For Each Sayfa In ThisWorkbook.Worksheets
        If Sayfa.Name <> "DATA" Then
            If S1.Range("A1") = "" Then Sayfa.Range("A1:B1").Copy S1.Range("A1")
            Sayfa.Range("A2:B" & Sayfa.Cells(Sayfa.Rows.Count, 1).End(3).Row).Copy S1.Cells(S1.Rows.Count, 1).End(3)(2, 1)
        End If
    Next

    S1.Columns.AutoFit

    Set S1 = Nothing
  
    MsgBox "Sayfalar konsolide edilmiştir.", vbInformation
End Sub

diyelikm ki bunun için H1 hücresini kullanacaksınız. Aiağıdaki kodu kendi kodunuza ekleyip dener misiniz

Code:
-----
Range("H1") = "=MID(CELL(""dosyaadı""),FIND(""]"",CELL(""dosyaadı""))+1,100)"
Range("H1").Value = Range("H1").Value
------

 

[netkit]

Sayın baydeniro;
Evet H1 e "DATA" yı yazıyor sadece alt satırlara başka sayfa ismi yazmıyor.

 

[baydeniro]

Sayın baydeniro;
Evet H1 e "DATA" yı yazıyor sadece alt satırlara başka sayfa ismi yazmıyor.

o zaman konu üstadlık seviyesinde

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Consolidate_All_Sheets()
    Dim Sayfa As Worksheet, S1 As Worksheet, Satir As Long
   
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("DATA").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
   
    Set S1 = Sheets.Add(, Sheets(Sheets.Count))
    S1.Name = "DATA"
   
    For Each Sayfa In ThisWorkbook.Worksheets
        If Sayfa.Name <> "DATA" Then
            If S1.Range("A1") = "" Then
                Sayfa.Range("A1:B1").Copy S1.Range("A1")
                S1.Range("C1").Font.Bold = True
                S1.Range("C1") = "Sayfa Adı"
            End If
            Satir = S1.Cells(S1.Rows.Count, 1).End(3)(2, 1).Row
            Sayfa.Range("A2:B" & Sayfa.Cells(Sayfa.Rows.Count, 1).End(3).Row).Copy S1.Cells(Satir, 1)
            S1.Range("C" & Satir & ":C" & S1.Cells(S1.Rows.Count, 1).End(3).Row) = Sayfa.Name
        End If
    Next

    S1.Columns.AutoFit

    Set S1 = Nothing
   
    MsgBox "Sayfalar konsolide edilmiştir.", vbInformation
End Sub

 

[netkit]

Korhan Bey çok teşekkür ederim. elinize sağlık ..