Satırdaki Değer Değişince Yeni Sheet'e o satırı kopyalamak

[onurshn]

Merhaba,

Elimde bir excel dosyası var bu dosyanın A sütununda 16 tane "a" değeri olsun, 17. satırdan itibaren 5 tane "b" değeri..Benim istediğim makro bu 16 satırı ayrı ve bu 5 satırı ayrı iki excel dosyası haline getirecek bir makro.

Şimdiden yardımınız için teşekkürler..

 

[dEdE]

Sayın onurshn

Forumumuza hoşgeldiniz.
Aşağıdaki kodları bir modüle yapıştırın. Dosya yolunu kendinize göre değiştirin.

Sub Yedek_Al()
    Dim Dosya_Adı As String
    Set r1 = Sheets(1).Range("A1:IV16")
    Set r2 = Sheets(1).Range("A17:IV21")
For i = 1 To 2
Application.ScreenUpdating = False
If i = 1 Then
    r1.Select
    Else
    r2.Select
End If
    Selection.Copy
If i = 1 Then
    Dosya_Adı = "ilk.xls"
    Else
    Dosya_Adı = "ikinci.xls"
End If
    Workbooks.Add
    ActiveSheet.Paste
    Range("A1").Select
    ActiveWorkbook.SaveCopyAs Filename:="C:\Users\toshıba\Desktop" & Application.PathSeparator & Dosya_Adı
    ActiveWorkbook.Close 0
    Sheets("Sayfa1").Range("A1").Select
Application.ScreenUpdating = True
Next
    MsgBox "Yedekleme işlemi tamamlanmıştır.", vbInformation
End Sub

 

[onurshn]

Dede,

Yardımın için teşekkürler, dosya 16000 satırdan oluşuyor ve A sütunundaki değişim sıklığı stabil değil, buna göre oluşacak dosya sayısı 500'e yakın olacak diye düşünüyorum, makroda bu şekilde bir düzenlemeyi nasıl yapabilirim?

 

[dEdE]

dosya 16000 satırdan oluşuyor ve A sütunundaki değişim sıklığı stabil değil, buna göre oluşacak dosya sayısı 500'e yakın olacak diye düşünüyorum, makroda bu şekilde bir düzenlemeyi nasıl yapabilirim?

Merhaba,
Sorunu baştan tam olarak açıklasanız gereksiz yazışmalara yol açmazdık. Forumumuzun düzeni için bunun gerekli olduğunu düşünüyorum.

Gelelim sorunuzun yanıtına. A sütunundaki değişimin neye göre yapılacağı önemli. Stabil olmadığına göre(satır no gibi) o zaman değişime neden olacak değerleri kontrol ederek değişimin gerçekleştiği satır numaralarını bulmak gerekir.

Kolay gelsin.

 

[onurshn]

Özetle şudur, A sütunundaki sayı değiştikçe yeni bir çalışma kitabı oluşturup A sütununda aynı değerin bulunduğu tüm satırı o kitaba kopyalayan bir makro. Örneğin; 2 değeri 15 adet bu 15 satırın tamamını ayrı bir kitaba, 3 değeri 10 adet bu 10 satırın tamamını ayrı bir kitaba gibi. Önceki cevabımda belirttiğim üzere bu excel dosyası yaklaşık 16000 satırdan oluşuyor.

Bu hususları dikkate aldığınızda yazdığınız makroyu uygun hale nasıl getirebilirim?

 

[Necdet]

Özetle şudur, A sütunundaki sayı değiştikçe yeni bir çalışma kitabı oluşturup A sütununda aynı değerin bulunduğu tüm satırı o kitaba kopyalayan bir makro. Örneğin; 2 değeri 15 adet bu 15 satırın tamamını ayrı bir kitaba, 3 değeri 10 adet bu 10 satırın tamamını ayrı bir kitaba gibi. Önceki cevabımda belirttiğim üzere bu excel dosyası yaklaşık 16000 satırdan oluşuyor.

Bu hususları dikkate aldığınızda yazdığınız makroyu uygun hale nasıl getirebilirim?

Sorunuzu örnek dosya ile sorsaydınız çok daha çabuk yanıt alırdınız ve insanları da gereksiz yere yormazdınız diye düşünüyorum.

 

[dEdE]

Bu hususları dikkate aldığınızda yazdığınız makroyu uygun hale nasıl getirebilirim?

Merhaba,
Belirttiğiniz hususları gerçekleştiren kodlar aşağıdadır. Güle güle kullanın.

DİKKAT:
- Orjinal dosyanızın yedeğini almadan kodu çalıştırmayınız.
- Dosya sayısı fazla olacağından, orjinal dosyanızı ayrı bir klasöre kopyalayıp, kodu bu klasörde çalıştırırsanız oluşan dosyalarınız bir arada olur.
- Koddaki dosya yolunu kendinize göre değiştirmelisiniz.
- Oluşacak dosya sayısı fazla olacağından (siz öyle yazmışsınız) işlem uzun sürebilir.

Sub Yedek_Al()
    Dim Dosya_Adı As String
    Dim Aktar As String
Application.ScreenUpdating = False
Set s1 = Sheets(1)
ilk = Cells(1, 1).Row
Dosya_No = 0
    Sheets(1).Range("A1").Select
    Range("A1:IV20000").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
            
For i = 2 To [A65536].End(3).Row + 1
    Aktar = s1.Cells(i - 1, 1).Value
    If s1.Cells(i, 1).Value <> Aktar Or s1.Cells(i, 1).Value = "" Then
        ilk = son + 1
        son = s1.Cells(i, 1).Row - 1
        s1.Range("A" & ilk & ":" & "IV" & son).Select
        Selection.Copy
         
        Dosya_No = Dosya_No + 1
        Dosya_Adı = "Dosya" & Dosya_No & ".xls"
        Workbooks.Add
        ActiveSheet.Paste
        Range("A1").Select
        ActiveWorkbook.SaveCopyAs Filename:="C:\Users\toshıba\Desktop" & Application.PathSeparator & Dosya_Adı
        ActiveWorkbook.Close 0
        Sheets("Sayfa1").Range("A1").Select
    End If
Next i
MsgBox "Dosya Ayırma İşlemi Tamamlanmıştır.", vbInformation, "dEdE Başarılar diler.."
    Application.ScreenUpdating = True
End Sub

 

[truvali27m]

Merhaba,
Belirttiğiniz hususları gerçekleştiren kodlar aşağıdadır. Güle güle kullanın.

DİKKAT:
- Orjinal dosyanızın yedeğini almadan kodu çalıştırmayınız.
- Dosya sayısı fazla olacağından, orjinal dosyanızı ayrı bir klasöre kopyalayıp, kodu bu klasörde çalıştırırsanız oluşan dosyalarınız bir arada olur.
- Koddaki dosya yolunu kendinize göre değiştirmelisiniz.
- Oluşacak dosya sayısı fazla olacağından (siz öyle yazmışsınız) işlem uzun sürebilir.

Sub Yedek_Al()
    Dim Dosya_Adı As String
    Dim Aktar As String
Application.ScreenUpdating = False
Set s1 = Sheets(1)
ilk = Cells(1, 1).Row
Dosya_No = 0
    Sheets(1).Range("A1").Select
    Range("A1:IV20000").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
            
For i = 2 To [A65536].End(3).Row + 1
    Aktar = s1.Cells(i - 1, 1).Value
    If s1.Cells(i, 1).Value <> Aktar Or s1.Cells(i, 1).Value = "" Then
        ilk = son + 1
        son = s1.Cells(i, 1).Row - 1
        s1.Range("A" & ilk & ":" & "IV" & son).Select
        Selection.Copy
         
        Dosya_No = Dosya_No + 1
        Dosya_Adı = "Dosya" & Dosya_No & ".xls"
        Workbooks.Add
        ActiveSheet.Paste
        Range("A1").Select
        ActiveWorkbook.SaveCopyAs Filename:="C:\Users\toshıba\Desktop" & Application.PathSeparator & Dosya_Adı
        ActiveWorkbook.Close 0
        Sheets("Sayfa1").Range("A1").Select
    End If
Next i
MsgBox "Dosya Ayırma İşlemi Tamamlanmıştır.", vbInformation, "dEdE Başarılar diler.."
    Application.ScreenUpdating = True
End Sub

Çalışmanızla ilgili bir örnek sayfa koyabilir misiniz acaba bize de yarayacak özellikler olabilir.Sayın dede bu kodları bir örnek sayfa üzerinde yapıp ekleyebilir misiniz size zahemt ;-) biz de bakalım yani diyecektim..Teşekkür ederim.

 

[onurshn]

Dede,

Son verdiğiniz kod çok işime yaradı, yardımınız için teşekkürler. Örnek vermediğim ve sizi gereksiz yere yorduğum için kusura bakmayın.

Not: Necdet Yeşertener, örnek vermediğim ve yazdıklarımı okurken göstermiş olduğunuz aşırı efor ve gayret nedeniyle kusura kalmayın. hiçbirşey için teşekkürler

Saygılarımla,

 

[dEdE]

Çalışmanızla ilgili bir örnek sayfa koyabilir misiniz

Örnek çalışma ilişikte.

Son verdiğiniz kod çok işime yaradı, yardımınız için teşekkürler.

Rica ederim. Güle güle kullanın.

Bu arada koddaki dosya adı satırını aşağıdaki ile değiştirirseniz, yeni dosyalara Dosya1, Dosya2..... gibi isimler yerine A sütunundaki değişen parametrenin adını verir. Böylece dosyanın adından içeriğinide anlamış oluruz.
Ekli örnek bu şekilde değiştirilmiştir.

 Dosya_Adı = s1.Cells(i - 1, 1).Value & ".xls"

 

[sevdalinka_61]

merhaba arkadaşlar;
benim bir problemim var, excelde bir sayfada 1den çok sütun var ve bu sütunlardan bir tanesine göre (örneğin "bakiye" sütununa göre) negatif olan bütün satırları başka bir çalışma sayfasına göndermek istiyorum. bunu makroyla nasıl yapabilirim bana yardımcı olursanız sevinirim...

 

[dEdE]

Merhaba,
Forumumuza hoşgeldiniz.
Yeni konu için yeni başlık açarsanız daha iyi olur.
Sorunuzu örnek dosya ile desteklerseniz daha çabuk yanıt alırsınız.
Hoşçakalın.