A sütununda aynı olanları seçsin ve tek tek dosya haline getirsin

[murbal]

Merhaba Arkadaşlar,

Yaklaşık 10 saattir uğraşıyorum ama ancak dosyadaki kadar yapabildim.

1. Dosyamda macro düğmesine her seferinde basmam gerekiyor, nasıl çözerim.
2. sütun arasında boşluk varsa eğer o zaman papazı buldum çünkü sağa doğru ancak boşluğa kadar işaretliyor, tüm satırı nasıl işaretlemem gerekiyor,
3. dosyayı kaydetsin ve a2 hücresini kopyalayarak dosya ismini aynısı yapsın.

Lütfen yardım edin. teşekkürler...

 

[tahsinanarat]

Ekli dosyanızı incelermisiniz

Yapmak istediğiniz bu mudur,

 

[murbal]

Tam değil

Merhaba Arkadaşım,

öncelikle ilginiz için çok teşekkür ederim, tam olarak bu değil...

1. tüm satırdaki bilgileri almalı,
2. başlığıda almalı,
3. excel sayfası sheet değil, excel book olmalı ve a2 hücresinin ismini vererek pc de herhangi bir yere save etmeli...

tşk,

 

[murbal]

Yardım edecek kimse tok mu?

Arkadaşlar,

Benim sorunuma çare olacak kimse yok mu?

 

[murbal]

yardım lütfeennnn...

 

[veyselemre]

Sub AsutunundakiVerilereGoreYeniKitaplaraAktar()
Dim rForDelete As Range
Dim c As Range
    Application.ScreenUpdating = False

    Set wb = ActiveWorkbook
    Set s1 = Sheets.Add
    Sheets("Ham_data").Select
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=s1.Range("a1"), Unique:=True
    pth = wb.Path

    son = [a65536].End(3).Row
    bolgeler = s1.Range("a2", s1.[a65536].End(3))
    Application.DisplayAlerts = False
    s1.Delete

    For Each bolge In bolgeler
        Sheets("Ham_data").Copy
        Set wb1 = ActiveWorkbook
        For Each c In Range(Cells(2, 1), Cells(son, 1))
            If c.Value <> bolge Then
                If rForDelete Is Nothing Then
                    Set rForDelete = c
                Else
                    Set rForDelete = Union(rForDelete, c)
                End If
            End If
        Next

        If Not rForDelete Is Nothing Then rForDelete.EntireRow.Delete
        Set rForDelete = Nothing
        wb1.SaveAs Filename:=pth & "\" & bolge
        wb1.Close
        wb.Activate
    Next
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Set wb = Nothing
    Set s1 = Nothing
    Set c = Nothing
End Sub

 

[murbal]

Abi ne diyeyim ki...

Ellerine sağlık, süper olmuş, işte budur, minnettarım size... ama benim de böyle yazabiliyor olmam gerek, fakat tek başına zor sanırım...

tekrar tekrar teşekkür ederim...