• DİKKAT

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

Range seçimi kendim belirleyeyim

  • Konbuyu başlatan Konbuyu başlatan k0081
  • Başlangıç tarihi Başlangıç tarihi
k0081

k0081

Katılım
17 Haziran 2008
Mesajlar
1,874
Excel Vers. ve Dili
Microsoft Ofis Profesyonel 2019 x64 TR
Merhaba arkadaşlar;

Range("F1:K57").Select bu satırı, değiştirmek istiyorum. her sayfada adresler farklı olduğu için, kendim mouse ile belirlemek istiyorum.. bunu nasıl yapabilirim ?

yardımcı arkadaşa şimdiden teşekkürler..
 
Merhaba,

Kod: 
Set alan = Application.InputBox("Alan Secin", "Aralık değiştirme", Type:=8)

Gibi bir yapı ile fare ile alan seçebilirsiniz ve bu alanı kodlarda kullanabilirsiniz. Örnek dosya olmadığı için sizin dosyanıza uyarlamayamadım.
 
Ömer' Alıntı:
Merhaba,

Kod: 
Set alan = Application.InputBox("Alan Secin", "Aralık değiştirme", Type:=8)

Gibi bir yapı ile fare ile alan seçebilirsiniz ve bu alanı kodlarda kullanabilirsiniz. Örnek dosya olmadığı için sizin dosyanıza uyarlamayamadım.
Genişletmek için tıkla ...

hocam çok teşekkürler.. tamamdır.. aynen budur..
 
Ömer' Alıntı:
Kod: 
Dim ts, trabzonspor
Set ts = CreateObject("Wscript.Shell")
trabzonspor = ts.Specialfolders.Item("Desktop")
[COLOR="Red"]Sheets("kolon").Select[/COLOR]
Set alan = Application.InputBox("Alan Secin", "Aralık değiştirme", Type:=8)
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.PageSetup.PrintArea = "$A$1:$F$57"
ActiveWorkbook.SaveAs Filename:= _
trabzonspor & "\" & Range[COLOR="red"]("D3")[/COLOR] & ".xls", FileFormat:= _
xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
ActiveWorkbook.Close
ActiveWindow.ScrollRow = 40
hocam bu kodda değişiklik yaptım sizin vermiş olduğunuz kod satırı ile.. kırmızı ile işaretli yerlerde hata oluyor hocam,, masaüstüne benim belirttiğim aralıkta bir dosya kaydı oluşturmasını istiyorum. Dosya ismi herzaman için aynı olabilir. mesela yedek.xls olabilir.. bunu yapmaya çalışıyorum...
Genişletmek için tıkla ...
 
Hata aldığınız dosyayı eklermisiniz.
 
Son düzenleme:
Tam olarak yapmak istediğinizi detaylı açıklarmısınız.
 
Ömer' Alıntı:
Tam olarak yapmak istediğinizi detaylı açıklarmısınız.
Genişletmek için tıkla ...

bir çalışma kitabında , 10-15 adet ayrı sayfa var. her sayfanın tablo tasarımı farklı (ebatlar.. vs..). yapmak istediğim, daha önce göndermiş olduğunuz koddaki gibi, ( o kodları çalıştırabilseydim, soruyu sormayacaktım zaten.) sayfanın yedeğini masaüstüne almak. dosya adı yedek.xls olabileceği gibi, sheet ismide olabilir... normalde bunu yaptırıyorum ilk göndermiş olduğum kod ile... Ama o kodu her sayfa için ayrı ayrı düzenlemek gerekiyor.. bende bu düzenleme olayını ortadan kaldırmak için, seçili alanı direk masaüstüne kayıt yapan bir kod oluşturmak istemiştim..
 
İlk olarak verdiğim kod, her sayfada çalışır. Kodları standart bir module kopyaladıktan snra İsterseniz sayfa üzerinden butona kodları atarsınız isterseniz Alt F8 ile çalıştırırsınız.
Neden çalıştıramadığınız anlayamadım.

Bunuda açıklarsanız çalıştırma metodunu ona göre yeniden düzenlerim.

2. sorum ise masa üstüne kayıt edilecek dosya adı ne olacak, yada nasıl belirlenecek?

.
 
Ömer' Alıntı:
İlk olarak verdiğim kod, her sayfada çalışır. Kodları standart bir module kopyaladıktan snra İsterseniz sayfa üzerinden butona kodları atarsınız isterseniz Alt F8 ile çalıştırırsınız.
Neden çalıştıramadığınız anlayamadım.

Bunuda açıklarsanız çalıştırma metodunu ona göre yeniden düzenlerim.

2. sorum ise masa üstüne kayıt edilecek dosya adı ne olacak, yada nasıl belirlenecek?

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

hocam ilk verdiğiniz kod çalışıyor, yani daha doğrusu işlemi yapıyor.. hata vermeden.. ama dosya oluşmuyor masaüstünde... belki bu kullandığım PC ile alakalı da olabilir tam bilemiyorum.. başka bir bilgisayarda deneyeceğim..

2- dosya adı = yedek.xls olsun.
 
Bu kodu denermisiniz.

Kod: 
Sub DESKTOP_BACKUP()
Dim klasor
klasor = CreateObject("Wscript.Shell").Specialfolders.Item("Desktop")
adres = ActiveWindow.RangeSelection.Address
a = InStr(Trim(adres), ":")
If a = 0 Then MsgBox "Kopyalanacak alanı seçmediniz.": Exit Sub
Application.DisplayAlerts = False
uzanti = Right(ThisWorkbook.Name, InStr(1, StrReverse(ThisWorkbook.Name), ".", vbTextCompare))
If uzanti = ".xls" Then
FileFormatNum = -4143
ElseIf uzanti = ".xlsx" Then
FileFormatNum = 51
ElseIf uzanti = ".xlsm" Then
FileFormatNum = 52
ElseIf uzanti = ".xlsb" Then
FileFormatNum = 50
End If
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
ActiveSheet.PageSetup.PrintArea = adres '"$A$1:$F$57"
ActiveWorkbook.SaveAs Filename:=klasor & "\yedek" [COLOR=red]& uzanti[/COLOR], FileFormat:=FileFormatNum
ActiveWorkbook.Close
ActiveWindow.ScrollRow = 40
Application.DisplayAlerts = True
End Sub
 
k0081' Alıntı:
hocam ilk verdiğiniz kod çalışıyor, yani daha doğrusu işlemi yapıyor.. hata vermeden.. ama dosya oluşmuyor masaüstünde... belki bu kullandığım PC ile alakalı da olabilir tam bilemiyorum.. başka bir bilgisayarda deneyeceğim..

2- dosya adı = yedek.xls olsun.
Genişletmek için tıkla ...

Denedim, herhangi bir sorun yok. Sadece dosya adı kısmını değiştirdim. Dosya ektedir.
 

Ekli dosyalar

halit3' Alıntı:
halit hocam bu göndermiş olduğunuz kod oldu. çalışıyor.. sadece oluşan dosyayı masaüstünden açtığımda; Açmaya çalıştığınız yedek.xls dosyası dosya uzantısı tarafından belirtilenden farklı biçimde diye devam eden bi ileti geliyor açmak istiyormusunuz diyor evet diyorum ve dosya açılıyor.. bu ileti dışında tamamdır hocam teşekkürler...
***************

Ömer hocam;

out of memory hatası aldım göndermiş olduğunuz dosyadan.. debug dediğimde yönlenen kısım :
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
 
    If Intersect(Target, Range("D2:D3")) Is Nothing Then Exit Sub
 
    With Application
        [COLOR="Red"]If Target <> "" Then[/COLOR]
            .EnableEvents = False
            Target = UCase(Replace(Replace(Target, "ı", "I"), "i", "İ"))
            If Target.Address = "$D$4" Then Target = _
                                Replace(Target, "*", "x")
            .EnableEvents = True
        End If
    End With

End Sub
Genişletmek için tıkla ...
 
Yukarıdaki mesajdaki kodun kırmızı yerini düzelttim.

Not: masa üstündeki yedek dosyayı silin ondan sonra deneyin.
 
halit3' Alıntı:
Yukarıdaki mesajdaki kodun kırmızı yerini düzelttim.

Not: masa üstündeki yedek dosyayı silin ondan sonra deneyin.
Genişletmek için tıkla ...


Hocam çok teşekkürler.. tamamdır.. elinize sağlık..
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst