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

 

[pitchoute]

Merhabalar, bu şekilde deneyip sonucu paylaşabilir misiniz;

Sub Button1_Click()

    Dim startPath As String
    Dim myName1 As String
    Dim folderPathWithName As String
    Dim dosyaAdi As String
    Dim wb_New As Workbook
    Dim ws_New As Worksheet
    Dim sourceRange1 As Range
    Dim sourceRange2 As Range
    Dim targetCell As Range
    
    startPath = "C:\Users\OP"
    myName1 = ActiveSheet.Range("C6").Text & "_" & ActiveSheet.Range("C8").Text
    folderPathWithName = startPath & Application.PathSeparator & myName1 & Application.PathSeparator
    dosyaAdi = "Laufkarte_" & ActiveSheet.Range("C6").Text & "_" & ActiveSheet.Range("C13").Text & "Pcs" & ActiveSheet.Range("E20").Text & ActiveSheet.Range("A1").Text & ".xlsx"

    If Dir(folderPathWithName, vbDirectory) = vbNullString Then
        MkDir folderPathWithName
    Else
        MsgBox "Klasör zaten mevcut."
    End If
    
    Set wb_New = Workbooks.Add
    Set ws_New = wb_New.Sheets(1)
    
    ' Kopyalamak istediğiniz hücre aralıklarını tanımlayın
    ' Örneğin, B2:D20 aralığını kopyalamak için:
    Set sourceRange1 = ActiveSheet.Range("B2:D20")
    ' Eğer başka bir aralığı daha kopyalamak isterseniz
    ' Set sourceRange2 = ActiveSheet.Range("F2:H20")
    
    sourceRange1.Copy
    ws_New.Range("A1").PasteSpecial Paste:=xlPasteAll
    
    ' İkinci aralığı kopyalamak isterseniz
    ' sourceRange2.Copy
    ' ws_New.Range("E1").PasteSpecial Paste:=xlPasteAll
    
    Application.CutCopyMode = False
    
    If Dir(folderPathWithName & dosyaAdi) <> "" Then
        MsgBox "Bu isimde bir dosya zaten var. Dosyayı kaydetmeyi iptal ediyorum.", vbExclamation, "Uyarı"
        wb_New.Close SaveChanges:=False
        Exit Sub
    End If
    
    Application.DisplayAlerts = False
    wb_New.SaveAs Filename:=folderPathWithName & dosyaAdi, FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    
    ' İsterseniz yeni çalışma kitabını kapatabilirsiniz
    ' wb_New.Close
    
    MsgBox "Yeni dosya başarıyla oluşturuldu.", vbInformation, "İşlem Tamamlandı"

End Sub

 

[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

 

[pitchoute]

Kopyalanacak veriler için tekrar bir düzenleme yaptım, şöyle deneyip sonucu paylaşabilir misiniz;

Sub Button1_Click()
    On Error GoTo ErrorHandler
    Application.ScreenUpdating = False
    
    Dim startPath As String
    Dim myName1 As String
    Dim folderPathWithName As String
    Dim dosyaAdi As String
    Dim wb_New As Workbook
    Dim ws_New As Worksheet
    Dim sourceRange1 As Range
    ' Dim sourceRange2 As Range ' Eğer başka bir aralığı da kopyalamak isterseniz
    Dim sourceSheet As Worksheet
    ' Dim targetCell As Range ' Gerekirse kullanılabilir
    
    Set sourceSheet = ThisWorkbook.Sheets("Sayfa1")
    
    startPath = "C:\Users\OP"
    myName1 = sourceSheet.Range("C6").Text & "_" & sourceSheet.Range("C8").Text
    folderPathWithName = startPath & Application.PathSeparator & myName1 & Application.PathSeparator
    dosyaAdi = "Laufkarte_" & sourceSheet.Range("C6").Text & "_" & sourceSheet.Range("C13").Text & "Pcs" & sourceSheet.Range("E20").Text & sourceSheet.Range("A1").Text & ".xlsx"
    
    If Dir(folderPathWithName, vbDirectory) = vbNullString Then
        MkDir folderPathWithName
    Else
        ' Eğer klasör zaten varsa devam etmek istiyorsanız bu mesajı kaldırabilirsiniz
        ' MsgBox "Klasör zaten mevcut."
    End If
    
    Set wb_New = Workbooks.Add
    Set ws_New = wb_New.Sheets(1)
    
    Set sourceRange1 = sourceSheet.Range("C9:C208") ' "C9:C208" aralığını kendi ihtiyacınıza göre ayarlayın
    
    ws_New.Range("D11").Resize(sourceRange1.Rows.Count, sourceRange1.Columns.Count).Value = sourceRange1.Value
    
    ws_New.Range("D11:D" & 10 + sourceRange1.Rows.Count).RemoveDuplicates Columns:=1, Header:=xlNo
    
    If Dir(folderPathWithName & dosyaAdi) <> "" Then
        MsgBox "Bu isimde bir dosya zaten var. Dosyayı kaydetmeyi iptal ediyorum.", vbExclamation, "Uyarı"
        wb_New.Close SaveChanges:=False
        GoTo CleanUp
    End If
    
    Application.DisplayAlerts = False
    wb_New.SaveAs Filename:=folderPathWithName & dosyaAdi, FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    
    ' İsterseniz yeni çalışma kitabını kapatabilirsiniz
    ' wb_New.Close
    
    MsgBox "Yeni dosya başarıyla oluşturuldu.", vbInformation, "İşlem Tamamlandı"
    
CleanUp:
    Application.ScreenUpdating = True
    Exit Sub
    
ErrorHandler:
    MsgBox "Bir hata oluştu: " & Err.Description, vbCritical
    Application.ScreenUpdating = True
End Sub

 

[addigital]

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

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

 

[pitchoute]

Sayfa adını doğru yazdığınız sürece bir problem çıkmaması gerekiyor hocam

 

[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