secili hücre araligi kaydi

[addigital]

öncelikle herkese merhaba
forumda arattirsim ancak istedigime yakin bri cevap bulamadim.
excelde makro kullanarak 2 adet butonum var. olustur butonu yardimiyla yeni bir excel aciliyor ve activesheet icerigini buraya kopyaliyor. olusturulan yeni excelde ekledigim butonlari ve a1 sütununu görmek istemiyorum. sadece benim sececegim hücre araliklarini yeni acilan excele yapistirsin istiyorum. ugrastim ama malesef bir cözüm bulamadim..

bu konuda bana yardim edecek arkadaslar var mi?

kod blogum bu sekilde

Sub Button1_Click()

Dim startPath As String
Dim myName1 As String
Dim folderPath As String
Dim dosyaAdi As String
Dim folderPathWithName As String
Dim wb_New As Workbook

startPath = "C:\Users\OP"
myName1 = ActiveSheet.Range("C6").Text & "_" & ActiveSheet.Range("C8").Text
folderPath = "C:\Users\OP" & "Karte" & ActiveSheet.Range("C6").Text & ActiveSheet.Range("C13").Text & ActiveSheet.Range("E24").Text & ActiveSheet.Range("A1").Text
dosyaAdi = "Karte" & ActiveSheet.Range("C6").Text & "_" & ActiveSheet.Range("C15").Text & "Pcs" & ActiveSheet.Range("E20").Text & ActiveSheet.Range("A1").Text & ".xlsm"
folderPathWithName = startPath & Application.PathSeparator & myName1 & Application.PathSeparator

If Dir(folderPathWithName, vbDirectory) = vbNullString Then
MkDir folderPathWithName
Else
MsgBox "Folder already exists"


End If
ActiveSheet.Copy
Application.DisplayAlerts = False

ActiveWorkbook.SaveAs Filename:=folderPathWithName & ("Laufkarte") & ("_") & ActiveSheet.Range("C6").Text & ("_") & ActiveSheet.Range("C13").Text & ("Pcs") & ActiveSheet.Range("E20").Text & ActiveSheet.Range("A1").Text
FileFormat = xlOpenXMLActiveWorkbookMacroDisabled
Application.DisplayAlerts = True
If Dir(ActiveWorkbook.Path & "\" & dosyaAdi) <> "" Then
MsgBox "Bu isimde bir dosya zaten var. Dosyayi kaydetmeyi iptal ediyorum.", vbExclamation, "Uyari"
Exit Sub
End If

 

[tugkan]

Sorununuzu çözmek için yeni Excel dosyasına sadece istediğiniz hücre aralıklarını yapıştırabilir ve butonlar ile A1 sütununu gizleyebilirsiniz. Aşağıda kodunuzu buna göre güncelledim:

1. Butonları kaldırmak: Yeni açılan Excel'de butonların kopyalanmasını engelleyeceğiz.
2. A1 sütununu gizlemek: A1 sütununu saklayacağız.
3. Belirli hücre aralıklarını kopyalama: Sadece sizin belirttiğiniz hücre aralıklarını kopyalayacağız.

İşte güncel kodunuz:

Sub Button1_Click()

    Dim startPath As String
    Dim myName1 As String
    Dim folderPath As String
    Dim dosyaAdi As String
    Dim folderPathWithName As String
    Dim wb_New As Workbook
    Dim ws As Worksheet
    Dim wsNew As Worksheet

    startPath = "C:\Users\OP"
    myName1 = ActiveSheet.Range("C6").Text & "_" & ActiveSheet.Range("C8").Text
    folderPath = "C:\Users\OP" & "Karte" & ActiveSheet.Range("C6").Text & ActiveSheet.Range("C13").Text & ActiveSheet.Range("E24").Text & ActiveSheet.Range("A1").Text
    dosyaAdi = "Karte" & ActiveSheet.Range("C6").Text & "_" & ActiveSheet.Range("C15").Text & "Pcs" & ActiveSheet.Range("E20").Text & ActiveSheet.Range("A1").Text & ".xlsm"
    folderPathWithName = startPath & Application.PathSeparator & myName1 & Application.PathSeparator

    ' Klasör var mı kontrol et, yoksa oluştur
    If Dir(folderPathWithName, vbDirectory) = vbNullString Then
        MkDir folderPathWithName
    Else
        MsgBox "Folder already exists"
    End If
    
    ' Yeni bir Excel kitabı oluştur
    Set wb_New = Workbooks.Add
    Set wsNew = wb_New.Sheets(1)
    
    ' Belirli hücre aralıklarını kopyala (örneğin: B2:D10)
    ActiveSheet.Range("B2:D10").Copy Destination:=wsNew.Range("A1")
    
    ' A1 sütununu gizle
    wsNew.Columns("A").Hidden = True
    
    ' Yeni dosyayı kaydet
    Application.DisplayAlerts = False
    wb_New.SaveAs Filename:=folderPathWithName & ("Laufkarte") & ("_") & ActiveSheet.Range("C6").Text & ("_") & ActiveSheet.Range("C13").Text & "Pcs" & ActiveSheet.Range("E20").Text & ActiveSheet.Range("A1").Text, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    Application.DisplayAlerts = True

    MsgBox "Yeni dosya başarıyla oluşturuldu ve kaydedildi."

End Sub

Açıklamalar:

• Range("B210").Copy: Kopyalanacak hücre aralığını buradan ayarlayabilirsiniz. İstediğiniz aralığı buraya yazarak özelleştirin.
• wsNew.Columns("A").Hidden = True: Bu satır, yeni dosyada A sütununu gizler.
• Application.DisplayAlerts = False/True: Kaydetme sırasında uyarıları gizleyip tekrar açar.

Bu şekilde butonlar kopyalanmayacak ve sadece belirttiğiniz hücre aralıkları yeni dosyaya taşınacaktır.

 

[addigital]

hocam cevabiniz icin tesekkür ederim. ayni sekilde uyguladim ancak bos bir excel sayfasi aciliyor. kod calisiyor ancak sanirim ölzellestirmede bir hata yapiyorum.
sadece activesheet icerisinde bu islemi yapabilecegim bir durum var mi?
biraz daha detay vermem gerekirse , butonumun bulundugu excel de bazi bilgiler var ve ben bu exceli butonsuz ve sadece sectigim alani kaydettirmek istiyorum.

 

[tugkan]

Anladım. Amacınız, mevcut çalışma sayfanızdaki belirli bir hücre aralığını seçip, butonlar ve diğer gereksiz içerikler olmadan, yalnızca seçilen verileri yeni bir Excel dosyasına kopyalamak. Ayrıca, bu yeni dosyada A1 sütununu gizlemek istiyorsunuz.

Mevcut aktif sayfadan veri kopyalama işlemini gerçekleştirip butonları ve gereksiz içeriği dahil etmeden sadece belirttiğiniz alanı kaydetmek için aşağıdaki düzenlenmiş kodu deneyin:

Güncel Kod:

Sub Button1_Click()

    Dim startPath As String
    Dim myName1 As String
    Dim folderPath As String
    Dim dosyaAdi As String
    Dim folderPathWithName As String
    Dim wb_New As Workbook
    Dim wsNew As Worksheet

    startPath = "C:\Users\OP"
    myName1 = ActiveSheet.Range("C6").Text & "_" & ActiveSheet.Range("C8").Text
    folderPath = "C:\Users\OP" & "Karte" & ActiveSheet.Range("C6").Text & ActiveSheet.Range("C13").Text & ActiveSheet.Range("E24").Text & ActiveSheet.Range("A1").Text
    dosyaAdi = "Karte" & ActiveSheet.Range("C6").Text & "_" & ActiveSheet.Range("C15").Text & "Pcs" & ActiveSheet.Range("E20").Text & ActiveSheet.Range("A1").Text & ".xlsm"
    folderPathWithName = startPath & Application.PathSeparator & myName1 & Application.PathSeparator

    ' Klasör var mı kontrol et, yoksa oluştur
    If Dir(folderPathWithName, vbDirectory) = vbNullString Then
        MkDir folderPathWithName
    Else
        MsgBox "Folder already exists"
    End If
    
    ' Yeni bir Excel kitabı oluştur
    Set wb_New = Workbooks.Add
    Set wsNew = wb_New.Sheets(1)
    
    ' Belirli hücre aralıklarını kopyala (örneğin: B2:D10)
    ActiveSheet.Range("B2:D10").Copy
    
    ' Yeni sayfaya yapıştır
    wsNew.Range("A1").PasteSpecial Paste:=xlPasteValues ' Sadece değerleri yapıştır
    wsNew.Range("A1").PasteSpecial Paste:=xlPasteFormats ' Biçimlendirmeyi yapıştır
    
    Application.CutCopyMode = False ' Kopyalama modunu kapat

    ' A1 sütununu gizle
    wsNew.Columns("A").Hidden = True
    
    ' Yeni dosyayı kaydet
    Application.DisplayAlerts = False
    wb_New.SaveAs Filename:=folderPathWithName & ("Laufkarte") & ("_") & ActiveSheet.Range("C6").Text & ("_") & ActiveSheet.Range("C13").Text & "Pcs" & ActiveSheet.Range("E20").Text & ActiveSheet.Range("A1").Text, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    Application.DisplayAlerts = True

    MsgBox "Yeni dosya başarıyla oluşturuldu ve kaydedildi."

End Sub

Yapılan Değişiklikler:

1. Kopyalama ve yapıştırma işlemi: ActiveSheet.Range("B210").Copy ile belirtilen alanı kopyalıyoruz. Daha sonra yeni Excel'de PasteSpecial kullanarak sadece değerleri ve biçimlendirmeleri yapıştırıyoruz.
   • xlPasteValues: Sadece hücrelerin değerlerini kopyalar.
   • xlPasteFormats: Hücrelerin biçimlendirmesini kopyalar.
2. A1 sütunu gizleniyor: wsNew.Columns("A").Hidden = True ile A sütununu gizliyoruz.

Öneriler:

• Kopyalama alanını: ActiveSheet.Range("B210").Copy kısmında istediğiniz hücre aralığını düzenleyin.
• Bu kod, butonlar dahil olmadan sadece belirlediğiniz hücre aralıklarını kopyalayıp yeni Excel dosyasına yapıştıracaktır. Ayrıca, A sütununu gizleyecek ve sadece değerler ile biçimlendirmeyi yapıştıracaktır.

Kodun çalıştığından emin olmak için hücre aralığınızı ve kopyalama işlemini dikkatlice kontrol edebilirsiniz.

 

[tugkan]

bazı formüllerde çıkıyor. oraları birleşik olarak ":" ve "D" yapmanız lazım

 

[addigital]

cok tesekkürler hocam ancak
yine bos bir excel görüntülüyorum. yapistirmada özellestirdigim a2 ve e 29 sütonlari secili geliyor ancak icerik bos kopyalamadan önce select ile sectirmeyi de denedim

 

[addigital]

Merhaba lar cevabiniz icin cok tesekkür ederim. ancak hala bir bos sayfa görüntülüyorum. excel dosya edite acik olup olmadigini kontrol ettim belki bundan kopyalam islemini yapamiyor diye ama editze acik oldugu halde kopyalama yapmiyor. istedigim hersey olmus aslinda yapistirma olayida tqama cunku yeni acilan excelde yazdigim hücre araliklari secili geliyor. ama ici bos anlayamadim neden

 

[addigital]

-Set sourceSheet = ThisWorkbook.Sheets("Sayfa1")-

bu kodu kendi sheet ime göre ayarliyorum ancak burda bir hata veriyor.

 

[addigital]

tamamdir hocam sorunu cözdüm sadece kodlarla ilgili bir mantik hatasi yapiyormusum. tugkan hocamin verdigi kodlari sirasiyla islem yapacak sekilde dizdim. pitchoute hocam sizin yapistirma kodlarinizi da ekledim. bu sekilde suanda tam istedigim gibi bir sayfa görüntülüyorum. yalniz simdi baska bir sorun rtaya cikti. exceli ayni sekilde almiyor. örnegin a1 hücresi genis a2 hücresi biraz daha kisa, kenarliklarim var bu sekilde yapistirmiyor.

wsNew.Range("A1").PasteSpecial Paste:=xlPasteFormats
kodu kullandim ancak yine normal kopyala yapistir yapiyor. bunun icin yapabilecegim bri sey var mi?


Sub Button1_Click()

Dim startPath As String
Dim myName1 As String
Dim folderPath As String
Dim dosyaAdi As String
Dim folderPathWithName As String
Dim wb_New As Workbook
Dim ws_New As Worksheet

startPath = "C:\Users\"
myName1 = ActiveSheet.Range("C7").Text & "_" & ActiveSheet.Range("C8").Text
folderPath = "M:\HtxOrga\OP\LaufkarteOzi\" & "Laufkarte" & ActiveSheet.Range("C7").Text & ActiveSheet.Range("C15").Text & ActiveSheet.Range("E24").Text & ActiveSheet.Range("A1").Text
dosyaAdi = "Laufkarte_" & ActiveSheet.Range("C7").Text & "_" & ActiveSheet.Range("C15").Text & "Pcs" & ActiveSheet.Range("E24").Text & ActiveSheet.Range("A1").Text & ".xlsm"
folderPathWithName = startPath & Application.PathSeparator & myName1 & Application.PathSeparator

If Dir(folderPathWithName, vbDirectory) = vbNullString Then
MkDir folderPathWithName
Else
MsgBox "Folder already exists"


End If

ActiveSheet.Range("A2:E28").Select
ActiveSheet.Range("A2:E28").Copy

Set wb_New = Workbooks.Add
Set wsNew = wb_New.Sheets(1)

wsNew.Range("A1").PasteSpecial Paste:=xlPasteAll
wsNew.Range("A1").PasteSpecial Paste:=xlPasteFormats

Application.DisplayAlerts = False

wb_New.SaveAs Filename:=folderPathWithName & ("Laufkarte") & ("_") & ActiveSheet.Range("C7").Text & ("_") & ActiveSheet.Range("C15").Text & ("Pcs") & ActiveSheet.Range("E24").Text & ActiveSheet.Range("A1").Text
FileFormat = xlOpenXMLActiveWorkbookMacroDisabled
Application.DisplayAlerts = True
If Dir(ActiveWorkbook.Path & "\" & dosyaAdi) <> "" Then
MsgBox "Bu isimde bir dosya zaten var. Dosyayi kaydetmeyi iptal ediyorum.", vbExclamation, "Uyari"
Exit Sub
End If

 

[addigital]

pitchoute ve tugkan hocam yardimlariniz icin cok tesekkür ederim. isteidigim gibi kopyalamayi basardim. kodumun son hali

Set sourceRange = ActiveSheet.Range("A2:E28")
sourceRange.Copy

Set wb_New = Workbooks.Add
Set wsNew = wb_New.Sheets(1)

wsNew.Range("A1").PasteSpecial Paste:=xlPasteAll
wsNew.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme

For i = 1 To sourceRange.Rows.Count
wsNew.Rows(i).RowHeight = sourceRange.Rows(i).RowHeight
Next i


For j = 1 To sourceRange.Columns.Count
wsNew.Columns(j).ColumnWidth = sourceRange.Columns(j).ColumnWidth
Next j



tam istedigim sonucu sayenizde aldim. size ne kadar cok tesekkür etsem azdir. iyiki varsin axcel web tr.

 

[tugkan]

kodumun son hali

Sinirli şekilde okuyunca farklı bir anlam çıkıyor ))))

Halletsiysen güzel.

 

[addigital]

Sinirli şekilde okuyunca farklı bir anlam çıkıyor ))))

Halletsiysen güzel.

hocam simdi yine okudum gercekten öyle haha