VBA Sayfa Ekleme ve İsim Kontrol Etme

[kesiq]

Merhabalar,

Örnekte bulunan elimdeki C sutunu ve E sutununda bulunan bazı veriler mevcut. Bu verilere göre makroyla sayfa açmak ve o verinin adını vermek istiyorum. Örneğin C sutunu şu şekilde; C1= Ahmet,C2=Mehmet C3=Ayşe,C4=Ahmet,C5=Ayşe. Program C sutunundaki yinelenmeyen isimlerde sayfa ekleyecek ve sayfaların isimleri Ahmet,Mehmet şeklinde olacak. Aynı şekilde E sutunu içinde açılacak.Aşağıda bir kod yazdım fakat sayfa adı aynı hatasını alıyorum bir yerde bir eksiklik var.

Sub sayfaekleme()

Dim dolusatir As Integer

dolusatir = Sheets("pintopin").UsedRange.Rows.Count

MsgBox dolusatir

Dim From() As String

Dim Frompin() As String

Dim Tooo() As String

Dim Tooopin() As String

Dim WS As Worksheet



ReDim From(dolusatir)

ReDim Frompin(dolusatir)

ReDim Tooo(dolusatir)

ReDim Tooopin(dolusatir)

For i = 1 To dolusatir

From(i - 1) = Sheets("pintopin").Cells(i + 1, 3)

Frompin(i - 1) = Sheets("pintopin").Cells(i + 1, 4)

Tooo(i - 1) = Sheets("pintopin").Cells(i + 1, 5)

Tooopin(i - 1) = Sheets("pintopin").Cells(i + 1, 6)

Next

For i = 2 To dolusatir



 

For y = 1 To i



  If From(i - 2) <> Sheets(y).Name Then

  GoTo Ekleme

 

  End If

  Next

Ekleme:

Worksheets.Add

ActiveSheet.Name = From(i - 2)

  Next


End Sub

 

[Necdet]

Merhaba,

C sütununa göre sayfa açar, kodları kendinize göre uyarlayınız.

Sub SayfaAc()

    Dim d
    Dim i As Long
    Dim a
    Dim k
    Dim sh As Worksheet
    
    Set sh = ActiveSheet
    
    Set d = CreateObject("Scripting.Dictionary")
    
    For i = 1 To Cells(Rows.Count, "C").End(3).Row
        k = Cells(i, "C")
        If Not d.exists(k) Then d.Add k, ""
    Next i
    
    a = d.keys
    
    For i = 0 To d.Count - 1
        If Not SayfaVarMi(a(i)) Then
            Sheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = a(i)
            sh.Select
        End If
    Next i
    
End Sub

Function SayfaVarMi(SayfaAdi) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(SayfaAdi).Name) > 0)
End Function

 

[kesiq]

Merhaba,

C sütununa göre sayfa açar, kodları kendinize göre uyarlayınız.

Sub SayfaAc()

    Dim d
    Dim i As Long
    Dim a
    Dim k
    Dim sh As Worksheet
   
    Set sh = ActiveSheet
   
    Set d = CreateObject("Scripting.Dictionary")
   
    For i = 1 To Cells(Rows.Count, "C").End(3).Row
        k = Cells(i, "C")
        If Not d.exists(k) Then d.Add k, ""
    Next i
   
    a = d.keys
   
    For i = 0 To d.Count - 1
        If Not SayfaVarMi(a(i)) Then
            Sheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = a(i)
            sh.Select
        End If
    Next i
   
End Sub

Function SayfaVarMi(SayfaAdi) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(SayfaAdi).Name) > 0)
End Function

Kod için çok teşekkür ederim çalıştı fakat söyle bir sorunum çıktı C sutunundaki hücre verilerinde isimlerin bazıları C3=m8516:shld şeklinde : ile yazılmış. Bu yüzden hücre değerinde : nokta varsa bu hücre için sayfa oluşturmaması lazım ve bu : noktalı hücre değerini değişken içerisinde tutması gerekiyor. Yardımcı olabilir misiniz?

 

[Necdet]

Merhaba,
Koddaki ilk döngüyü aşağıdaki şekilde değiştiriniz.

    For i = 1 To Cells(Rows.Count, "C").End(3).Row
        If Not Cells(i, "C") Like "*:*" Then
            k = Cells(i, "C")
            If Not d.exists(k) Then d.Add k, ""
        End If
    Next i

 

[kesiq]

Merhaba,
Koddaki ilk döngüyü aşağıdaki şekilde değiştiriniz.

    For i = 1 To Cells(Rows.Count, "C").End(3).Row
        If Not Cells(i, "C") Like "*:*" Then
            k = Cells(i, "C")
            If Not d.exists(k) Then d.Add k, ""
        End If
    Next i

Merhabalar değiştirdim fakat olmadı. Resimde a nın aldığı değeri görebilirsiniz.

 

[veyselemre]

Sub SayfaAc()
    Set sh = ActiveSheet
    With CreateObject("Scripting.Dictionary")
     
        For Each i In Sheets
            .Add Trim(i.Name), ""
        Next i

        For Each i In Range("C:C,E:E").SpecialCells(xlCellTypeConstants)
            If Not .exists(i.Text) And Not InStr(i.Text, ":") > 0 Then
                .Add i.Text, ""
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = i.Text
            End If
        Next i
 
    End With
    sh.Select
End Sub

Sub olmayanSayfalariAcSirala()
    Set sh = ActiveSheet
    With CreateObject("System.Collections.ArrayList")
        For Each i In Sheets
            .Add i.Name
        Next i
        For Each i In Range("C:C,E:E").SpecialCells(xlCellTypeConstants)
            If .indexOf(i.Text, 0) = -1 And Not InStr(i.Text, ":") > 0 Then
                .Add i.Text
                Sheets.Add(after:=Sheets(Sheets.Count)).Name = i.Text
            End If
        Next i
        .Sort
        .Remove sh.Name
        If .Count > 0 Then
            lst = .toArray
            For i = 0 To UBound(lst)
                Sheets(lst(i)).Move after:=Sheets(Sheets.Count)
            Next i
        End If
    End With
    sh.Select
End Sub

 

[Necdet]

Merhabalar değiştirdim fakat olmadı. Resimde a nın aldığı değeri görebilirsiniz.

Hücre değerinde : dan söz ettiniz, tire vs de olur demediniz, sadece : kontrolü yapmıştım.

 

[kesiq]

Hücre değerinde : dan söz ettiniz, tire vs de olur demediniz, sadece : kontrolü yapmıştım.

Merhabalar Veysel beyin yaptığı kod sorunumu çözdü. Vba konusunda daha yeniyim sayfaları oluşturdum şimdi yapmak istediğim kod şöyle;

Excelimi eke koyuyorum. Amacım şu; C sutununda yazan isimlere göre sayfalar açtım. Bu sayfalara şimdi o c sutunundaki hücre değerleri eşleşenleri satır halinde o sayfada toplaması. Örneğin Sayfa adı W82545_p1 c deki isimlerden hangisi bu sayfayla örtüşürse onun satırını direk o sayfaya yazıcak. C4 ile eşleşti mesela A4,B4,C4,D4,E4,F4 satırını o eşleştiği sayfaya 2 numaralı satırdan başlayarak yerleştirecek ve aktarıldığından emin olmak için pin to pin sayfasının K sutununa aktarıldı diye tik ya da aktarıldı yazması. Kodu for if döngüleriyle yapmaya çalıştım fakat ilgim yeterli olmadı sanırım.

Deneme Excel