• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Tek dosyadaki bilglieri kurum kurum ayırıp kaydetme

K

karacakamil

Katılım
31 Aralık 2009
Mesajlar
58
Excel Vers. ve Dili
2007
DENEME ANA SAYFA dosyasını parçalayacağız. bu dosyada denemeler "tüm kurumlar" birlikte sıralı şekilde.
Amacımız bu denemeleri kurumlar için ayrı ayrı "kurumun isimiyle" parçalamak. Her kurumun listesinde sadece kendi öğrencileri olacak. Zaten dosyanın yanında bir de "OLMASI İSTENEN AYRILMIŞ HALLİ DOSYA ÖRNEĞİ" diye olmasını beklediğim son halini de elle oluşturup gönderdim. Amacım bunu makro ile yapmak
Şimdiden teşekkür ederim.
( Dosyalar örnektir. Bu dosyalara bakarak daha büyük dosyalar üzerinde çalışacağım.)

Dosya linki: http://s6.dosya.tc/server8/pzbdoe/DOSYA_PARCALAMA-ACIL_ACIL_ACIL.rar.html
 

Ekli dosyalar

Yardımcı olabilecek var mı arkadaşlar? Aciliyeti var . Desteklerinizi bekliyorum
 
Merhaba
Ek dosyayı inceleyin
Dosyalar\işlemci adlı "xlsm" dosyası işlem yapacak dosyadır, açıp butona basmanız yeterli
"DENEME ANA SAYFA" bu dosyanın yanında olsun açmanıza gerek yok,
"klasör" adlı klasör içine; parçalanacak sayfalar kaydedilecek
Kırmızı bölüme asıl dosyanızın adını yazabilir veya koddaki adı verebilirsiniz
uzantıya dikkat edin.
http://s3.dosya.tc/server10/gecb1c/Dosyalar.zip.html
Kod: 
Private Sub CommandButton1_Click()
Set a = CreateObject("scripting.filesystemobject")
Workbooks.Open ThisWorkbook.Path & "\DENEME ANA SAYFA.xlsx"
Set s1 = Workbooks("DENEME ANA SAYFA")
For Each j In s1.Sheets
For x = 3 To s1.Sheets(j.Name).Cells(Rows.Count, "C").End(3).Row
gelen = ThisWorkbook.Path & "\Klasör\" & Trim(s1.Sheets(j.Name).Cells(x, "C")) & ".xlsx"
If Not a.FileExists(gelen) Then
s1.SaveCopyAs gelen
Workbooks.Open gelen
For Each j2 In ActiveWorkbook.Sheets
For x2 = ActiveWorkbook.Sheets(j2.Name).Cells(Rows.Count, "C").End(3).Row To 3 Step -1
If Trim(s1.Sheets(j.Name).Cells(x, "C")) <> Trim(ActiveWorkbook.Sheets(j2.Name).Cells(x2, "C")) Then
ActiveWorkbook.Sheets(j2.Name).Cells(x2, "C").EntireRow.Delete
End If
Next: Next
ActiveWorkbook.Close savechanges:=True
End If
Next: Next
End Sub
 
Son düzenleme:
Sayın PLİNT
Öncelikle Çok çok teşekkkür ederim. Bİir kaç sorum olacak;
1.Bu Kurum isimleri c veya d sütununda ise nereyi değiştirmeliyim?
2.Klasör içine kaydetme şeklini değiştirmek mümkün mü?
Şu şekilde olsun:
Önce yine klasör içine olsun,
sonra tekrar bir klasör daha fakat bu klasörün ismi "kurum ismi" olsun,
sonra kurum isimli klasördeki "excel" dosyasının ismi "ana dosyanin ismi" yani (DENEME ANA SAYFA) olsun.
 
Yukarıda değişen kodlarda "c" sütununa göre oldu isterseniz "d" yapabilirsiniz
Klasör isteğinizi anlayamadım.
 
ASIL DOSYAMIZ: DENEME ANA SAYFA
Şu anda makro çalıştığında ;
"KLASÖR" Adlı klasörde excel dosyaları oluşuyor. ve isimleri "KADIKÖY", "ÜMRANİYE", "SULTANBEYLİ" şeklinde

OLMASINI İSTEDİĞİM KAYIT ŞEKLİ İSE;
"KLASÖR" Adlı klasör İçinde otomatik "KADIKÖY", "ÜMRANİYE", "SULTANBEYLİ" şeklinde
oluşacak, bu klasörlerin içine her excell sayfasının ismi "DENEME ANA SAYFA" olacak. Yani parçalanan excell dosyaslarının isimleri hep aynı kalacak. ama farklı klasörlerde

anlatabildim mi?


ek olarak ; ASIL DOSYAMIZ olan : DENEME ANA SAYFA.xls nin ismini makroya koymadan kendisi otomatik olarak yapmış olduğunuz "İşlemci" makrolu excelin olduğu tüm excelleri tanıyıp hemen dediğim şekilde ayırma yapabilir mi?

Her excel çalışması için makroyu düzenlemeyeyim. Otomatik yanındaki tüm excell dosyalarını parçalasın

?

Olabiilir mi?

ÖRNEK OLARAK TEKRAR EK YÜKLEDİM;
LİNK:

http://s6.dosya.tc/server8/0tn1yc/YENI_CALISMA.rar.html
 
Bu arada tekrar teşekkür ederim. Gerçekten bu saatte yardım ediyorsunuz. Allah sizlerden razı olsun...
 
Alternatif ;

Aşağıdaki şekilde deneyiniz.
Kurum ismi olarak referansı 9SINIF tan alır.

http://s3.dosya.tc/server10/tzc7f6/Kurum_Dosya_Olustur.zip.html


Kod: 
Dim eskikurum, yol, orgdosya As String
'asriakdeniz@gmail.com   www.asriakdeniz.com

Sub menu()
   Application.DisplayAlerts = False
   orgdosya = ActiveWorkbook.Name
   
   yol = ActiveWorkbook.Path
   Sheets("9SINIF").Select
   Call sirala
   Sheets("10SINIF").Select
   Call sirala
   Call duzenle
   Application.DisplayAlerts = True
   MsgBox ("Dosya oluşturma işlemi tamamlandı")
End Sub

Sub duzenle()
  Sheets("9SINIF").Select
  sonsatir = Cells(Rows.Count, "A").End(3).Row
  For i = 3 To sonsatir + 1
    Sheets("9SINIF").Select
    kurum = Cells(i, 1)
    If i = 3 Then eskikurum = kurum
    If kurum <> eskikurum Then
       Call kaydet
       a = a
    End If
    eskikurum = kurum
  Next i
  
End Sub

Sub kaydet()

    Sheets(Array("9SINIF", "10SINIF")).Select
    Sheets("10SINIF").Activate
    Sheets(Array("9SINIF", "10SINIF")).Copy
    Sheets("9SINIF").Select
    yenidosya = ActiveWorkbook.Name
    
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    For i = sonsatir To 3 Step -1
      kurum1 = Cells(i, 1)
      If kurum1 <> eskikurum Then Rows(i).Delete
    Next i
    
    Sheets("10SINIF").Select
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    For i = sonsatir To 3 Step -1
      kurum1 = Cells(i, 1)
      If kurum1 <> eskikurum Then Rows(i).Delete
    Next i
    
    Dim h, klas As String
    Dim a As Long
    Dim dc, kayıt
    Set dc = CreateObject("Scripting.FileSystemObject")
    Set kayıt = CreateObject("wscript.Shell")
    klasana = yol & "\KLASOR"
    klas = yol & "\KLASOR" & "\" & eskikurum
    
    If dc.FolderExists(klasana) = False Then dc.CreateFolder klasana
    If dc.FolderExists(klas) = False Then dc.CreateFolder klas

    ActiveWorkbook.SaveAs yol & "\KLASOR\" & eskikurum & "\" & eskikurum & ".xlsx", FileFormat:=xlNormal
    Workbooks(eskikurum & ".xlsx").Close
    orgdosyaadi = Mid(orgdosya, 1, InStr(orgdosya, ".") - 1)
    Name yol & "\KLASOR\" & eskikurum & "\" & eskikurum & ".xlsx" As yol & "\KLASOR\" & eskikurum & "\" & orgdosyaadi & ".xlsx"
End Sub

Sub sirala()
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    sayfaadi = ActiveSheet.Name
    Range("A2:D1000000").Select
    ActiveWorkbook.Worksheets(sayfaadi).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(sayfaadi).Sort.SortFields.Add Key:=Range("A3:A7"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(sayfaadi).Sort.SortFields.Add Key:=Range("B3:B7"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(sayfaadi).Sort.SortFields.Add Key:=Range("C3:C7"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets(sayfaadi).Sort.SortFields.Add Key:=Range("D3:D7"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(sayfaadi).Sort
        .SetRange Range("A2:D" & sonsatir)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A3").Select
    Columns("C:C").EntireColumn.AutoFit
    Columns("B:B").EntireColumn.AutoFit
    Columns("D:D").EntireColumn.AutoFit
End Sub
 
Son düzenleme:
karacakamil' Alıntı:
ASIL DOSYAMIZ: DENEME ANA SAYFA
Şu anda makro çalıştığında ;
"KLASÖR" Adlı klasörde excel dosyaları oluşuyor. ve isimleri "KADIKÖY", "ÜMRANİYE", "SULTANBEYLİ" şeklinde

OLMASINI İSTEDİĞİM KAYIT ŞEKLİ İSE;
"KLASÖR" Adlı klasör İçinde otomatik "KADIKÖY", "ÜMRANİYE", "SULTANBEYLİ" şeklinde
oluşacak, bu klasörlerin içine her excell sayfasının ismi "DENEME ANA SAYFA" olacak. Yani parçalanan excell dosyaslarının isimleri hep aynı kalacak. ama farklı klasörlerdeanlatabildim mi?

..
Genişletmek için tıkla ...

Son mesajımdaki dosyayı kontrol ediniz.
 
Merhaba
Sn asri cevaplamış ama; alternatif olsun
İşlem yapılacak tüm dosyalarınız "HAM_DOSYALAR" klasörü içerisinde olsun.
http://s6.dosya.tc/server8/z2l9vm/Dosyalar.zip.html
Kod: 
[SIZE="2"]Private Sub CommandButton1_Click()
If Application.Workbooks.Count > 1 Then
MsgBox ThisWorkbook.Name & " HARİÇ DİĞER DOSYALARI KAPATINIZ."
Exit Sub: End If
Set a = CreateObject("scripting.filesystemobject")
yol = ThisWorkbook.Path
If a.FolderExists(yol & "\Klasör\") = False Then
a.CreateFolder yol & "\" & "Klasör"
Else
MsgBox "Dosyanızın yanında Klasör adlı bir klasör bulundu" & vbCrLf & _
"Bu klasörün adını değiştirip programı tekrar çalıştırınız"
Exit Sub: End If
Set f = a.GetFolder(ThisWorkbook.Path & "\HAM_DOSYALAR")
Set dc = f.Files
On Error Resume Next
For Each DOSYA In dc
Set Aç = New Excel.Application
Aç.Workbooks.Open DOSYA
Set s1 = Aç.Workbooks(Dir(DOSYA))
For Each j In s1.Sheets
For x = 3 To s1.Sheets(j.Name).Cells(Rows.Count, "A").End(3).Row
If a.FolderExists(yol & "\" & "Klasör\" & Trim(s1.Sheets(j.Name).Cells(x, "A"))) = False Then
a.CreateFolder yol & "\" & "Klasör\" & Trim(s1.Sheets(j.Name).Cells(x, "A"))
End If
gelen = ThisWorkbook.Path & "\Klasör\" & Trim(s1.Sheets(j.Name).Cells(x, "A")) & "\" & s1.Name
If Not a.FileExists(gelen) Then
s1.SaveCopyAs gelen
Workbooks.Open gelen
For Each j2 In ActiveWorkbook.Sheets
For x2 = ActiveWorkbook.Sheets(j2.Name).Cells(Rows.Count, "A").End(3).Row To 3 Step -1
If Trim(s1.Sheets(j.Name).Cells(x, "A")) <> Trim(ActiveWorkbook.Sheets(j2.Name).Cells(x2, "A")) Then
ActiveWorkbook.Sheets(j2.Name).Cells(x2, "A").EntireRow.Delete
End If: Next: Next
Application.DisplayAlerts = False
ActiveWorkbook.Close SaveChanges:=True
Application.DisplayAlerts = True
End If: Next: Next
If Err > 0 Then
MsgBox "BİR HATA OLUŞTU KONTROL EDİNİZ, İŞLEM TAMAMLANAMADI "
Aç.Quit
Exit Sub
End If
s1.Close SaveChanges:=False
Aç.Quit
Set Aç = Nothing: Set s1 = Nothing
Next
MsgBox " İŞLEM BİTTİ...!"
End Sub[/SIZE]
 
Çok teşekkür ederim. İşimi gördüm.
Bu işlemin tam tersini yapacak şekilde bir çalışma nasıl yapabiliriz.

Yani Ayrı ayrı dosyalardaki bu verileri tek dosyaya toplama, aynı işlemlerin tam tersi.?
 
Yukarıdaki bahsettiğim gibi bir çalışma olabilir mi?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst