Excel Sayfasındaki Dolu Hücreleri Yeni Çalışma Kitabına Kopyalama ve Kaydetme

[17bn57]

Makro ile yapmak istediklerim
1- Ornek dosyada c2:aı17 arasında dolu olan hücreleri seçip kopyalamak
2- yeni bir sayfa açmak ve kopyaladığım hücreleri "özel yapıştır/değerler"şeklinde açtığım sayfaya kopyalamak
3- yeni sayfayı çalışma kitabımın bulunduğu dizine "puantaj" ismiyle kaydetmek ve kapatmak
4- normal çalışma kitabımda çalışmaya devam etmek

Makro kaydet işlemi ile makromu oluşturdum. ancak 1. ve 3. maddedeki işlemleri yapamadım. yardım ederseniz sevinirim. şimdiden teşekkürler

 

[dEdE]

Merhaba,
Aşağıdaki kodu Modüle yapıştırıp dener misimiz?

Sub puantaj()
Application.ScreenUpdating = False
Sheets("puantaj").Range("C2:AI17").Copy
Sheets.Add after:=Sheets(Sheets.Count)
Selection.PasteSpecial Paste:=xlPasteValues
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\puantaj.xls"
    ActiveWorkbook.Close 1
    Sheets("puantaj").Select
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamamlandı", vbInformation, "dEdE " & Application.UserName & "'e Başarılar diler."
End Sub

 

[17bn57]

makro çalışıyor teşekkürler ancak 1. maddede belirttiği gibi sadece dolu hücreleri seçip kopyalamak istiyorum. buna da bir çözüm bulabilirmisiniz.

 

[dEdE]

makro çalışıyor teşekkürler ancak 1. maddede belirttiği gibi sadece dolu hücreleri seçip kopyalamak istiyorum. buna da bir çözüm bulabilirmisiniz.

Merhaba,
Çözüm mutlaka bulunur ama;C2-AI2 arasındaki tüm hücreler dolu. Bu durumda boş hücreleri cıkarırsak sütunlar kaymaz mı?
En iyisi olmasını istediğiniz şekli excel sayfası üzerinde gösterirseniz, yapmaya çalışırız. İlk mesajınızdaki örnek dosyanızın 3. sayfasında bu durumu açıklayıp dosyanızı güncelleyebilirsiniz.
Hoşçakalın.

 

[17bn57]

eksik bilgi için özür dilerim hücre derken satırlardan bahsediyorum yani c2:aı17 arasındaki dolu satırları kopyalasın yada şöylede olur c sütünunda dolu olan hücreleri bul c?:aı? arasını kopyala gibi

 

[dEdE]

Merhaba,
Aşağıdaki kodu dener misiniz?

Sub puantaj()
Application.ScreenUpdating = False
ss = Range("C" & Rows.Count).End(3).Row
Sheets("puantaj").Range("C2:AI" & ss).Copy
Sheets.Add after:=Sheets(Sheets.Count)
Selection.PasteSpecial Paste:=xlPasteValues
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\puantaj.xls"
    ActiveWorkbook.Close 1
    Sheets("puantaj").Select
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamamlandı", vbInformation, "dEdE " & Application.UserName & "'e Başarılar diler."
End Sub

 

[17bn57]

teşekkürler bu şimdilik işimi görür kendimde kodlara bakarak bişeyler yapmaya çalırım artık zahmet verdim size

 

[17bn57]

herkese kolay gelsin daha önce sorduğum soruyla alakalı olduğu için aynı konuya devam ediyorum.

ilk mesajımda sorduğum soruları aşağıdaki gibi değiştiriyorum. bu şekilde makro konusunda yardımcı olursanız çok sevinirim.

1- C3 hücresinden başlayarak B2 ve c2 hücrelerinde yazılı miktarda satır ve sütun seçilmesi ve bu seçimin kopyalanması
2- Dosyanın bulunduğu dizine puantaj.xls isminde yeni bir kitap açılması, eğer varsa varolan puantaj.xls kitabına seçimlerin özel yapıştır/değerler şeklinde yapıştırılması
3- Puantaj dosyasını kaydedip kapatmak ve normal dosyam üzerinde çalışmaya devam etmek istiyorum

dosya ektedir.

 

[17bn57]

arkadaşlar yardım edecek kimse yokmu lütfen biri baksın acil lazım bu kod

 

[dEdE]

Merhaba,
Aşağıdaki kodu dener misiniz?

Sub Puantaj()
Application.ScreenUpdating = False
Sheets("Sayfa1").Range(Cells(3, 3), Cells([B2].Value + 3, [C2].Value + 2)).Copy
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(ThisWorkbook.Path & "\puantaj.xls") = True Then
    Workbooks.Open (ThisWorkbook.Path & "\puantaj.xls")
    ss = ActiveWorkbook.Sheets(1).Range("A" & Rows.Count).End(3).Row
    Range("A" & ss).PasteSpecial Paste:=xlPasteValues
    ActiveWorkbook.Close 1
    GoTo ExitProc
Else
    Workbooks.Add
    Range("A1").PasteSpecial Paste:=xlPasteValues
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\puantaj.xls"
    ActiveWorkbook.Close
End If
ExitProc:
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamamlandı.", vbInformation, "dEdE " & Application.UserName & "'e Başarılar diler."
End Sub

 

[17bn57]

sayın dEdE teşekkür ederim kod istediğim gibi ama tek sorun varolan dosyada alta ekleme yapıyor benim istediğim içeriği değiştirmesi
yani puantaj isimli bir dosyam var ve bunun içinde 20 satırlık bilgi mevcut ben 18 satırlık yeni bilgi kaydetceksem önceki 20 satırlık bilginin silinmesini istiyorum. umarım anlatabilmişimdir.

 

[dEdE]

... puantaj isimli bir dosyam var ve bunun içinde 20 satırlık bilgi mevcut ben 18 satırlık yeni bilgi kaydetceksem önceki 20 satırlık bilginin silinmesini istiyorum...

Merhba,
Önceki açıklamanızdan bu anlaşılmıyordu. Ben de her ay arşiv olarak saklanacak diye böyle yapmıştım.
Şu kodu dener misiniz?

Sub Puantaj()
    Application.ScreenUpdating = False
    Dosya = ThisWorkbook.Path & "\puantaj.xls"
    Sat = [B2].Value + 3
    Sut = [C2].Value + 2
    Set Rng = Range(Cells(3, 3), Cells(Sat, Sut))
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(Dosya) = True Then
        Workbooks.Open (Dosya)
        ActiveWorkbook.Sheets(1).UsedRange.ClearContents
        [A1].Resize(Sat - 2, Sut - 2) = Rng.Value
        ActiveWorkbook.Close 1
        GoTo ExitProc
    Else
        Workbooks.Add
        [A1].Resize(Sat - 2, Sut - 2) = Rng.Value
        ActiveWorkbook.SaveAs Filename:=Dosya
        ActiveWorkbook.Close
    End If
ExitProc:
        Application.CutCopyMode = False
        Application.ScreenUpdating = True
        MsgBox "İşlem Tamamlandı.", vbInformation, "dEdE " & Application.UserName & "'e Başarılar diler."
End Sub

 

[17bn57]

Sayın dEdE kod şimdilik sorunsuz çalışıyor yardımlarınız için çok teşekkür ederim. bu yardımlarınıza karşılık bende forumda makro bilmesem de excel ile ilgili diğer konularda yardımcı olmaya çalışıyorum. iyi günler dilerim.