İstenilen ismin bulunduğu grupları aktarmak

[ASLAN7410]

Merhaba hayırlı geceler.

Ekte gönderdiğim excel dosyamın ilk sayfasında ANA VERİ şeklinde bir sayfam var.

Yapmak istediğim G1 hücresine yazmış olduğum isme göre, bu ismi D sütununda arayıp, ismin bulunduğu grubu kendi ismi ile yan sayfa açıp grupların arasına boşluk atarak aktarmasını istiyorum.

Yardımcı olur musunuz?

http://dosya.co/0q69x0tleh6n/ÖRNEK.xlsm.html
.

 

[PLİNT]

Merhaba
Şu kodları deneyiniz

http://s9.dosya.tc/server2/u2v8i0/ORNEK.zip.html

[SIZE="2"]Sub aktar()
Set s1 = Sheets("ANA VERİ")
For Each i In Sheets
If i.Name <> s1.Name Then
Application.DisplayAlerts = False
i.Delete
Application.DisplayAlerts = True
End If
Next
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Trim(s1.[G1].Value)
Set s2 = Sheets(Sheets.Count)
s2.Columns("A:E").ColumnWidth = 15.86
s2.Range("A1:E1").Value = s1.Range("A1:E1").Value
For a = 2 To s1.Cells(Rows.Count, "D").End(3).Row
s = s1.Cells(a, "D").End(xlDown).Row
If WorksheetFunction.CountIf(s1.Range("D" & a & ":D" & s), Trim(s1.[G1].Value)) > 0 Then
rw = s2.Cells(a, "a").End(xlUp).Row + 1
r = IIf(rw = 2, 2, rw + 1)
s1.Range("A" & a & ":E" & s).SpecialCells(xlCellTypeConstants, 3).Copy s2.Range("A" & r)
End If
a = s + 1
Next
End Sub[/SIZE]

 

[ASLAN7410]

Sayın PLİNT ellerinize sağlık, kodlar çok güzel çalışıyor.

Ancak G1 hücresine yazmış olduğum isimleri farklı farklı sayfa açmasını istiyorum.

 

[PLİNT]

O zaman "G1" deki isimli sayfa varsa silsin; yoksa eklesin

Sub aktar()
Set s1 = Sheets("ANA VERİ")
For Each i In Sheets
If i.Name = Trim([G1].Value) Then
Application.DisplayAlerts = False
i.Delete
Application.DisplayAlerts = True
End If
Next

Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Trim(s1.[G1].Value)
Set s2 = Sheets(Sheets.Count)
s2.Columns("A:E").ColumnWidth = 15.86
s2.Range("A1:E1").Value = s1.Range("A1:E1").Value
For a = 2 To s1.Cells(Rows.Count, "D").End(3).Row
s = s1.Cells(a, "D").End(xlDown).Row
If WorksheetFunction.CountIf(s1.Range("D" & a & ":D" & s), Trim(s1.[G1].Value)) > 0 Then
rw = s2.Cells(a, "a").End(xlUp).Row + 1
r = IIf(rw = 2, 2, rw + 1)
s1.Range("A" & a & ":E" & s).SpecialCells(xlCellTypeConstants, 3).Copy s2.Range("A" & r)
End If
a = s + 1
Next
End Sub

 

[ASLAN7410]

Sayın PLİNT çok teşekkür ederim, Allah razı olsun, tam istediğim gibi çalışıyor.

Hayırlı çalışmalar, hayırlı geceler diliyorum.

 

[PLİNT]

Sayın PLİNT çok teşekkür ederim, Allah razı olsun, tam istediğim gibi çalışıyor.
Hayırlı çalışmalar, hayırlı geceler diliyorum.

Rica ederim, hayırlı geceler.