Hücrelere Göre Yeni Sekme Açma

[RiskBagimlisi]

Merhaba arkadaşlar aranızda yeniyim,

H3 hücresinden BV3 hücresine kadar verim var her biri isim soyisim,

Yapmaya çalıştığım şey bu isimlerin hepsi ile yeni sayfa açmak

Ahmet,Mehmet,Ali gibi bu hücrelerde yazan isimler ile aynı olacak.

67 sayfa falan yapıyor sanırım.

Bu hücre isimleri değirse yada araya isim eklenip,silinirsede dinamik olarak sayfa eklenip,eksilmesi gerekli.

Kodlarla aram çok iyi değil, yardımcı olabilirseniz sevinirim.

 

[hüseyintok]

Merhaba deneyebilirsiniz.

Sub Hucreaktar()
Dim ws As Worksheet
Dim nameRange As Range
Dim cell As Range
Dim sheetName As String
Dim existingSheets As Collection
Dim i As Long

Set nameRange = ThisWorkbook.Sheets("Sheet1").Range("H3:BV3")


Set existingSheets = New Collection
For Each ws In ThisWorkbook.Sheets
On Error Resume Next
existingSheets.Add ws.Name, ws.Name
On Error GoTo 0
Next ws
For Each cell In nameRange
If cell.Value <> "" Then
sheetName = cell.Value
On Error Resume Next
existingSheets.Add sheetName, sheetName
If Err.Number = 0 Then
ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = sheetName
End If
On Error GoTo 0
End If
Next cell
For i = existingSheets.Count To 1 Step -1
On Error Resume Next
If IsError(Application.Match(existingSheets(i), nameRange, 0)) Then
Application.DisplayAlerts = False
ThisWorkbook.Sheets(existingSheets(i)).Delete
Application.DisplayAlerts = True
End If
On Error GoTo 0
Next i
End Sub

 

[RiskBagimlisi]

Günaydın Hüseyin bey, malesef çalıştıramadım kod kısmına verdiğiniz kodları yazdım,

daha sonra

Set nameRange = ThisWorkbook.Sheets("Sheet1").Range("H3:BV3")

kısmını

Set nameRange = ThisWorkbook.Sheets("Sayfa1").Range("H3:BV3")

olarak değiştirsem de sayfada bir değişiklik olmadı, yardımcı olabilir misiniz?

kodu yazıp kaydedip excel sayfasına geçtiğimde bir aksiyon bekliyorum, ekstra birşey yapmam gerekiyo mu ?

 

[hüseyintok]

Sub Hucreaktar2()
Dim ws As Worksheet
Dim nameRange As Range
Dim cell As Range
Dim sheetName As String
Dim existingSheets As Collection
Dim i As Long
Dim AnswerYes As String
Dim AnswerNo As String


Set nameRange = ThisWorkbook.Sheets("Sayfa1").Range("H3:BV3")

For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Sayfa1" Then
ws.Delete
End If
Next ws

Set existingSheets = New Collection
For Each ws In ThisWorkbook.Sheets
On Error Resume Next
existingSheets.Add ws.Name, ws.Name
On Error GoTo 0
Next ws


For Each cell In nameRange
If cell.Value <> "" Then
sheetName = cell.Value
On Error Resume Next
existingSheets.Add sheetName, sheetName
If Err.Number = 0 Then
ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = sheetName
End If
On Error GoTo 0
End If
Next cell

MsgBox ("Bitti")

End Sub

 

[RiskBagimlisi]

Çok teşekkürler elinize sağlık.