Bir Sutundaki Verileri Sheetlere Bolme

[tolgatrb]

Merhaba

Asagidaki linkteki dosyada DFR sheetinde yuklu bir data var.

https://www.dropbox.com/s/iups4dnpnarauur/ControlBuildingITRtracker.xlsx?dl=0

Benim yapmak istedigim bu datayi sheetlere bolmek. Yani Sub System sutunu altinda farkli farkli sistemler var. Benim istedigim her bir subsystem icin ayri bir sheet olusturup, o subsysteme ait butun verileri yeni sheete gecirmesi.

Yardimlariniz icin tesekkur ederim.

 

[antonio]

Aşağıdaki kodu deneyiniz:

Sub sekmeleri_isimlendirme()
Dim sh As Worksheet, ss As Long, z As Object, _
    aranan As String, n As Integer, i As Long, a(), _
    b
    
Set sh = Sayfa1
ss = sh.Range("A" & Rows.Count).End(3).Row
Set z = CreateObject("Scripting.Dictionary")
n = 0
a = sh.Range("A1:A" & ss).Value
ReDim b(1 To 1, 1 To UBound(a))
For i = 1 To UBound(a)
    If a(i, 1) <> "" Then
        aranan = a(i, 1)
        If Not z.exists(aranan) Then
            n = n + 1
            z.Add aranan, n
            ReDim Preserve b(1 To 1, 1 To n)
            b(1, n) = a(i, 1)
        End If
    End If
Next i
For d = 1 To Sheets.Count
    Sheets(d).Name = b(1, d)
Next d
End Sub

 

[Mustafa MUTLU]

Şunu deneyin
3 yerde değişiklik yapmanız gerekiyor
Kendinize ayarlamanız için,

Sub SayfaAc()
 For MM1 = 2 To Cells(65536, "[COLOR="Red"]B[/COLOR]").End(xlUp).Row 'Sub System sutunu, B sütunu olduğunu varsaydım, değilse siz düzeltin.
    MM = Cells(MM1, "[COLOR="red"]b[/COLOR]") ' Yukarıda değişiklik yaptıysanız, buradaki b de düzelecek
 
    MM2 = 0
    On Error Resume Next
    MM2 = Len(Sheets("" & MM & "").Name)
    If MM2 > 0 Then Exit Sub
    
    [a1] = MM
    Sheets.Add.Name = MM
    Sheets("[COLOR="red"]Sayfa1[/COLOR]").Select ' Sayfa1 yerine Sub System sütununun olduğu sayfa adı yazılacak

MSTF1 = [a1]
MSTF2 = 2
For MSTF = 2 To Cells(65536, "B").End(xlUp).Row
If Cells(MSTF, "B") = [a1] Then
Sheets(MSTF1).Cells(MSTF2, "B") = Cells(MSTF, "B")
Sheets(MSTF1).Cells(MSTF2, "C") = Cells(MSTF, "C")
Sheets(MSTF1).Cells(MSTF2, "D") = Cells(MSTF, "D")
MSTF2 = MSTF2 + 1
End If
Next

 Next
 MsgBox " İşlem Tamamlandı......", vbExclamation, "Mustafa MUTLU 0 533 740 45 49"
End Sub

 

[Mustafa MUTLU]

Sayın antonio nun cevabını görmedim.
Alternatif olsun....

 

[tolgatrb]

Şunu deneyin
3 yerde değişiklik yapmanız gerekiyor
Kendinize ayarlamanız için,

Sub SayfaAc()
 For MM1 = 2 To Cells(65536, "[COLOR="Red"]B[/COLOR]").End(xlUp).Row 'Sub System sutunu, B sütunu olduğunu varsaydım, değilse siz düzeltin.
    MM = Cells(MM1, "[COLOR="red"]b[/COLOR]") ' Yukarıda değişiklik yaptıysanız, buradaki b de düzelecek
 
    MM2 = 0
    On Error Resume Next
    MM2 = Len(Sheets("" & MM & "").Name)
    If MM2 > 0 Then Exit Sub
    
    [a1] = MM
    Sheets.Add.Name = MM
    Sheets("[COLOR="red"]Sayfa1[/COLOR]").Select ' Sayfa1 yerine Sub System sütununun olduğu sayfa adı yazılacak

MSTF1 = [a1]
MSTF2 = 2
For MSTF = 2 To Cells(65536, "B").End(xlUp).Row
If Cells(MSTF, "B") = [a1] Then
Sheets(MSTF1).Cells(MSTF2, "B") = Cells(MSTF, "B")
Sheets(MSTF1).Cells(MSTF2, "C") = Cells(MSTF, "C")
Sheets(MSTF1).Cells(MSTF2, "D") = Cells(MSTF, "D")
MSTF2 = MSTF2 + 1
End If
Next

 Next
 MsgBox " İşlem Tamamlandı......", vbExclamation, "Mustafa MUTLU 0 533 740 45 49"
End Sub

Mustafa Bey sizin yaptiginiz daha kolay oldu fakat tam istedigim degil. Dosyada DFR bolumunde bir subsystem birden fazla satirda var. ben o satirlari bulup yeni sheete aktarmasini, sheet ismininde ilgili subsystem olmasini istiyorum. tabi bunu dosya icerisinde bulunan butun subsystemler icin ayri ayri yapmasini istiyorum.