listeye göre ayrı ayrı excel sayfası oluşturma

[euphrates55]

sunum için hazırlamış olduğum bir excelim var. burada tek bir sayfa üzerinde işlem yapıyor ve iş adına göre seçtiğimde değerler değişiyor bunları da alıp sunuma kopyalıyorum. dosyam çok büyük olmasın diye bu şekilde yaptım. şimdi ise bunları listedeki isimlere göre sıra ile seçip her sayfayı dışarı atıp bir klasöre çıkaracak şekilde yazılacak kod var mı diye aklıma geldi. tembelliğim için kusura bakmayın ama böyle bir makro varsa çok güzel olur. örnek dosyamda istediğimi anlatmaya çalıştım.

 

[euphrates55]

Sizlerden ses çıkmayınca ben de boş durmadım tabi ki. makro kaydederek 1 işlemi yaptım ve kopyala yapıştır yaparak diğerlerinin hücre değerlerini değiştirerek uzunca bir işlem sonrası nihayete ermeyi düşünüyorum fakat sorularım olacak.

Sub SUNU()
'
' SUNU Makro
'

'
    Sheets("HÜCRE GİRİŞ").Select
    Range("Q1").Select
    Selection.Copy
    Sheets("sunu").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("sunu").Select
    Application.CutCopyMode = False
    Sheets("sunu").Copy
    Windows("ÖDENEK HARCAMA V4-2019.xlsm").Activate
    Sheets("HÜCRE GİRİŞ").Select
    Range("T1").Select
    Selection.Copy
    Range("AD1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Windows("Kitap1").Activate
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Users\msi\Desktop\soru\sunum\ihaleler\Amasya.xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
    Selection.ClearContents
    Sheets("sunu").Select

bu kodda Windows("Kitap1").Activate kısmında bazen hata veriyor. sanırım bazen kitap1 olarak yeni bir sayfada kopyala yapmıyor. kitap3 5 vs oluyor. bunu nasıl çözerim.

diğer sorum ise. "C:\Users\msi\Desktop\soru\sunum\ihaleler\Amasya.xlsx" _ kısmında, Range("AD1").Select yapıp ismi kopyalıyorum (yani amasya) ve kaydedilen yeni sayfa excele adını yapıştırıyorum. bu diğerleri için ad2 ad3....... olacak. bunu o hücreden otomatik isim aldırıp kaydettirme şansım var mı?

 

[Ömer BARAN]

Merhaba.
Keşke sadece kod metnini değil de bu kodun içerisinde olduğu ve özel bilgi içermeyen gerçek belgenin bir kopyasını ekleseydiniz.
Herneyse; birşey sorayım; HÜRE GİRİŞİ Q1 hücresini sunu sayfasında hangi hücreye yapıştırıyorsunuz o anlaşılmıyor.
Asıl sorduğunuz Kitap1 olayını da anlamadım doğrusu. İsterseniz kod ile yaptığınız/yapmak istediğiniz işlemi adım adım sözel olarak (belge adı, sayfa adı, hücre adresi gibi net ifade ederek) açıklarsanız daha iyi olur.

Kodlarda, mümkün olduğunca ...Select, ....Activate, ...Selection gibi kod kullanmayınız.
Örneğin, yanlış düşünmüyorsam; aşağıdaki kırmızı satırların yerine mavi olanı kullanabilirsiniz (sunu sayfasında hangi hücreye yapıştırılacağını anlamadığım için A1 yazdım)

Sonradan ilave not: konu açılış mesajındaki belgeyi fark etmemişim.

    Sheets("HÜCRE GİRİŞ").Select
    Range("Q1").Select
    Selection.Copy
    Sheets("sunu").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("sunu").[A1].Value=Sheets("HÜCRE GİRİŞ").[Q1].Value

 

[euphrates55]

ömer bey, kod yazamıyorum maalesef. makro kaydederek yaptım. sonrasında da her işlemim için kopyala yapıştır yapacağım ama kolay yolu varmıdırın peşindeyim. yaklaşık 80 işlemim olacak. sunu sayfasında v3 e değer olarak yapıştıracağım. daha sonra bu sayfa bir klasöre kopyalanacak ve bu seferde sırası ile q2 q3 ..... diye devam edecek. tüm liste kopyalanmış olacak. kaydedilen her sayfanın adı da s ve q nun birleşimi olacak. bunun için de hücre girişi sayfasında t3 e birleştir işlevi uyguladım ve bunu kopyalayıp değer olarak ad ye yapıştırıp buradan kopyalayıp, isim olarak yeni kaydetmeye çalıştığım dosya ismine yapıştırdım.

 

[Ömer BARAN]

Ama dikkat ederseniz isim olarak kullanacağız metinlerde **** karakterleri var.
Yanlış bilmiyorsam, bu tür özel karakterleri dosya adlarında kullanamazsınız.
Geçici olarak, belirttiğim **** karakterlerini, gerçek belgenizdekini temsil edebilecek nitelikte başka karakterlerle değiştirin.

 

[euphrates55]

Ama dikkat ederseniz isim olarak kullanacağız metinlerde **** karakterleri var.
Yanlış bilmiyorsam, bu tür özel karakterleri dosya adlarında kullanamazsınız.
Geçici olarak, belirttiğim **** karakterlerini, gerçek belgenizdekini temsil edebilecek nitelikte başka karakterlerle değiştirin.

teşekkürler.
kitap1 olayı şu. her sayfa kopyalamada dışarıya atarken kitap1 diye başlıyor sonrasında da kitap2...3... diye devam ediyor. eğerki daha önce bu işlem yapıldıysa bir sonraki sayıyı koyarak kitapx numarası veriyor. dolayısı ile ilk yazdığım kitap1 değişmiş olduğundan burada hata veriyor.

 

[Ömer BARAN]

Tekrar merhaba.
Belgenizde VBA bölümüne bakarsanız, ThisWorkbook (Bu Çalışma kitabı) kısmında Workbook_BeforeClose kod bloku mevcut.
İşlevini pek anlayamadım doğrusu, geçici olarak şöyle çözüm önereyim.
-- Belirttiğim Workbook_BeforeClose kod blokunun en başına aşağıdaki kod satırını ekleyin

If bekle = "DUR" Then Exit Sub

-- sunu isimli sayfaya bir adet düğme/şekil ekleyin,
-- aşağıdaki kod blokunu boş bir Module yapıştırın
-- eklediğiniz düğme/şekil ile aşağıdaki kodu ilişkilendirip çalıştırın.
-- Kod'daki 10 sayısı son işlem yapılacak HÜCRE GİRİŞİ sayfası satır numarasıdır bunu istediğiniz gibi değiştirin.
Veri olmayan satırlarda da formül olduğundan doğrudan son dolu satıra kadar şeklinde ekleme yapmadım.

DİKKAT: HÜCRE GİRİŞ sayfası T sütununda birbirinin aynı metnin olmadığından emin olun.

Public bekle
Sub FARKLI_KAYDET()
Set hg = Sheets("HÜCRE GİRİŞ"): Set s = Sheets("sunu")
bekle = "DUR"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    For sat = 1 To 10
        s.[V3] = hg.Cells(sat, "Q")
        ActiveSheet.Copy
        belge = ThisWorkbook.Path & "\ihaleler\" & hg.Cells(sat, "T").Value & ".xlsx"
        ActiveWorkbook.SaveAs belge
        ActiveWorkbook.Close
    Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
bekle = ""
End Sub

 

[euphrates55]

teşekkürler. çok yardımcı oldunuz. bazı hatalar veriyor ama muhtemelen yabancı karakter sorunu. gerisi bende. iyi geceler

düzenleme= tamamiyle : karakterinden kaynaklanıyor. her şey mükemmel

bahsettiğiniz kod ise gereksiz olan sekmeler çok yer kapladığı için silmiştim. hesaplar arası kontrol yapan bir kod var. muhtemelen odur. tekrar teşekkürler

 

[Ömer BARAN]

Estağfurullah, kolay gelsin.

 

[Ömer BARAN]

Tekrar merhaba.
Belirttiğiniz ":" karakteri ilgili hücrelerde kaçınılmaz olarak bulunmak durumundaysa;
(kaçınılmaz olarak bulunması muhtemel diğer özel karakterler için ilave Replace(..... , ":", "_") gibi eklemeler yapabilirsiniz)
ilgili satırı aşağıdakiyle değiştirerek kullanırsanız, ":" karakteri yerine "_" karakteri eklenerek işlem sorunsuz hale getirilebilir.

belge = ThisWorkbook.Path & "\ihaleler\" & Replace(hg.Cells(sat, "T").Value, ":", "_") & ".xlsx"

 

[euphrates55]

Tekrar merhaba.
Belirttiğiniz ":" karakteri ilgili hücrelerde kaçınılmaz olarak bulunmak durumundaysa;
(kaçınılmaz olarak bulunması muhtemel diğer özel karakterler için ilave Replace(..... , ":", "_") gibi eklemeler yapabilirsiniz)
ilgili satırı aşağıdakiyle değiştirerek kullanırsanız, ":" karakteri yerine "_" karakteri eklenerek işlem sorunsuz hale getirilebilir.

belge = ThisWorkbook.Path & "\ihaleler\" & Replace(hg.Cells(sat, "T").Value, ":", "_") & ".xlsx"

teşekkürler. ben de hücre girişi kısmında formüllemiştim.

=BİRLEŞTİR(SOLDAN(S41;20);"-";YERİNEKOY(SOLDAN(Q41;100);":";"="))

sizin dediğiniz şekilde daha mantıklı tabi. o zaman bir de / leri _ yapabiliyor muyuz.

 

[Ömer BARAN]

Verdiğim son cevaptaki kod satırında yer alan Replace(......) kısmını, aşadaki gibi yeni bir Replace arasına alarak ekleme yapabilirsiniz.

belge = ThisWorkbook.Path & "\ihaleler\" & Replace(Replace(hg.Cells(sat, "T").Value, ":", "_"),"/","_") & ".xlsx"

 

[euphrates55]

teşekkürler

 

[euphrates55]

Public bekle
Sub FARKLI_KAYDET()
Set hg = Sheets("HÜCRE GİRİŞ"): Set s = Sheets("sunu")
bekle = "DUR"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    For sat = 1 To 100
        s.[V3] = hg.Cells(sat, "Q")
        ActiveSheet.Copy
        belge = ThisWorkbook.Path & "\ihaleler\" & Replace(Replace(hg.Cells(sat, "T").Value, ":", "="), "/", "&") & ".xlsx"
        ActiveWorkbook.SaveAs belge
        ActiveWorkbook.Close
    Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
bekle = ""
End Sub

sormamak için çok çaba sarfettim ama beceremedim. son durumda bu kodu; dosyaları klasöre ayrı ayrı çıkararak değil de bir excel dosyasında toplayarak (güncelleyeyim mi, kaydedeyim mi diye sormadan) yeni bir excel dosyası yapacak ve sekme adları da v3 değerine eşit olacak kod için yardımlarınızı bekliyorum.