Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > EXCEL-Soruları > Makro-VBA
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Makro-VBA Makro veya VBA ile ilgili sorularınızı buraya gönderebilirsiniz.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 02-01-2018, 13:17   #11
PLİNT
 
Giriş: 31/12/2014
Şehir: Gürün
Mesaj: 1,322
Excel Vers. ve Dili:
Excel 2010
Varsayılan

Merhaba
Çerçevelerin silinmemesi isteğiniz için; yukarıdaki (9.mesajdaki) değişen kırmızı bölüm gibi kullanın.
Birinci isteğiniz:
"B:I" aralığında çalışan kodlar mesela "L:I" aralığındada çalışsın istiyorsunuz?
PLİNT Çevrimdışı   Alıntı Yaparak Cevapla
Eski 02-01-2018, 16:42   #12
DMR 7
 
Giriş: 14/09/2017
Şehir: Ankara
Mesaj: 77
Excel Vers. ve Dili:
2010 / Tr
Varsayılan

Alıntı:
PLİNT tarafından gönderildi Mesajı Görüntüle
Merhaba
Çerçevelerin silinmemesi isteğiniz için; yukarıdaki (9.mesajdaki) değişen kırmızı bölüm gibi kullanın.
Birinci isteğiniz:
"B:I" aralığında çalışan kodlar mesela "L:I" aralığındada çalışsın istiyorsunuz?
9. mesajdaki gibi kullandım hocam. amacım çercevelerin silinmemesi değil. o satırın biçiminin silinip, yukarıdaki kutuyu kopyaladıktan sonra, silinen çerçevelerin tekrar getirilmesi. neyse bu madde çok mühim değil manuel yapabilirim.

ilk istediğim. aralığın değişmesi değil hocam. yine "B:I" aralığında hali hazırda girilmiş numaraları kopyalayıp bir sağa yapıştırmak. örnek veriyorum. "B4:G30" aralığını komple seçip, kestikten sonra "C4:H30" a yapıştırmak istiyorum. bunu yaptığımda numaralar değişmiyor biçimleriyle. tek tek tüm kutulara birşey girip enterlamam gerekiyor.

ilginize teşekkür ederim
DMR 7 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 02-01-2018, 22:38   #13
PLİNT
 
Giriş: 31/12/2014
Şehir: Gürün
Mesaj: 1,322
Excel Vers. ve Dili:
Excel 2010
Varsayılan

Alıntı:
DMR 7 tarafından gönderildi Mesajı Görüntüle
o satırın biçiminin silinip, yukarıdaki kutuyu kopyaladıktan sonra, silinen çerçevelerin tekrar getirilmesi.
Ek dosyada buna göre ekleme yapmaya çalıştım, bakarsınız


Alıntı:
DMR 7 tarafından gönderildi Mesajı Görüntüle
örnek veriyorum. "B4:G30" aralığını komple seçip, kestikten sonra "C4:H30" a yapıştırmak istiyorum. bunu yaptığımda numaralar değişmiyor biçimleriyle. tek tek tüm kutulara birşey girip enterlamam gerekiyor.
Bu anlatımınıza göre ek dosyayı deneyiniz
"B4:G30" aralığını kesip/kopyalayıp,yapıştıracağınız aralığı seçip; "CTRL+b" ile yapıştırın.
Kopyaladıktan sonra yapıştırılacak bölümde tek hücre seçip yapıştırmak için aşağıdaki "kes_kopya" makrosunda kırmızı bölümleri silip deneyin.
(eğer bu kombinasyonun sakıncası varsa buton veya düğme ile yaparız)

http://s3.dosya.tc/server13/wwtwqw/Deneme1.zip.html

Kodlar
"Buçalışmakitabı"(thisworkbook) kod sayfası:
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.OnKey "^{b}"
End Sub

Private Sub Workbook_Open()
Application.OnKey "^{b}", "kes_kopya"
End Sub
"Modül1" kod sayfası:
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Sub kes_kopya()
If Selection.Cells.Count > 1 Then
If Intersect(ActiveCell, [B:I]) Is Nothing Or Application.CutCopyMode = 0 Then Exit Sub
Selection.PasteSpecial
For Each j In Selection.Cells
If j.Row = 1 Then MsgBox "Kes-kopyala 2.satırdan itibaren olmalıdır": Application.CutCopyMode = False: Exit Sub
If j.Value <> "" Then
x = j.Address
With Range("B" & j.Row & ":I" & j.Row)
.ClearFormats
.Value = ""
End With
Cells(1, j.Column).Copy Range(x)
Range("B" & j.Row & ":I" & j.Row).Borders.Weight = xlThin
End If
Next
End If
End Sub
Değişen "Deneme" sayfası kodları
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Private Sub Worksheet_Change(ByVal Target As Range)
If Selection.Cells.Count <> 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
If Intersect(Target, [B:I]) Is Nothing Then Exit Sub
Application.EnableEvents = False
If WorksheetFunction.CountIf(Range("B" & Target.Row & ":I" & Target.Row), "") < 7 Then
MsgBox "Bu satırda zaten veri var"
Target.Value = ""
Application.EnableEvents = True
Exit Sub
End If
With Range("B" & Target.Row & ":I" & Target.Row)
.ClearFormats
.Value = ""
End With
Range("A" & Target.Row & ":I" & Target.Row).Borders.Weight = xlThin
Cells(1, Target.Column).Copy Target
Application.EnableEvents = True
End Sub
PLİNT Çevrimdışı   Alıntı Yaparak Cevapla
Eski 03-01-2018, 09:11   #14
DMR 7
 
Giriş: 14/09/2017
Şehir: Ankara
Mesaj: 77
Excel Vers. ve Dili:
2010 / Tr
Varsayılan

Alıntı:
PLİNT tarafından gönderildi Mesajı Görüntüle

"B4:G30" aralığını kesip/kopyalayıp,yapıştıracağınız aralığı seçip; "CTRL+b" ile yapıştırın.
Kopyaladıktan sonra yapıştırılacak bölümde tek hücre seçip yapıştırmak için aşağıdaki "kes_kopya" makrosunda kırmızı bölümleri silip deneyin.
(eğer bu kombinasyonun sakıncası varsa buton veya düğme ile yaparız)
hocam çerçeve olayı olmuş. ama sanırım diğer kısmı çalıştırmayı ben beceremedim. makroda belirttiğin kırmızı satırları sildim. hücreleri kesip tek bir hücreye ctrl+b ile yapıştırmak istedim ve aşağıdaki debug uyarısı geldi ekrana. neyi yanlış yapıyorum ki?

bu arada tekrar tekrar teşekkür ederim emeğiniz için.


Bu mesaj en son " 03-01-2018 " tarihinde saat 09:47 itibariyle DMR 7 tarafından düzenlenmiştir....
DMR 7 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 03-01-2018, 10:08   #15
PLİNT
 
Giriş: 31/12/2014
Şehir: Gürün
Mesaj: 1,322
Excel Vers. ve Dili:
Excel 2010
Varsayılan

Merhaba
"Kes-yapıştırda" tek hücreyi denememiştim
Hata veren satırda:
"Selection pastespecial" yerine
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
activesheet.paste
PLİNT Çevrimdışı   Alıntı Yaparak Cevapla
Eski 03-01-2018, 10:13   #16
DMR 7
 
Giriş: 14/09/2017
Şehir: Ankara
Mesaj: 77
Excel Vers. ve Dili:
2010 / Tr
Varsayılan

Alıntı:
PLİNT tarafından gönderildi Mesajı Görüntüle
Merhaba
"Kes-yapıştırda" tek hücreyi denememiştim
Hata veren satırda:
"Selection pastespecial" yerine
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
activesheet.paste
Merhabalar hocam, allah razı olsun mükemmel olmuş )
DMR 7 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 03-01-2018, 10:24   #17
DMR 7
 
Giriş: 14/09/2017
Şehir: Ankara
Mesaj: 77
Excel Vers. ve Dili:
2010 / Tr
Varsayılan

Alıntı:
PLİNT tarafından gönderildi Mesajı Görüntüle
Merhaba
"Kes-yapıştırda" tek hücreyi denememiştim
Hata veren satırda:
"Selection pastespecial" yerine
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
activesheet.paste
hocam bu kodlar, herhangi bir geri dönüş yapmak istediğimizde "ctrl+z" ye izin verebilir mi?
DMR 7 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 03-01-2018, 18:32   #18
PLİNT
 
Giriş: 31/12/2014
Şehir: Gürün
Mesaj: 1,322
Excel Vers. ve Dili:
Excel 2010
Varsayılan

Alıntı:
DMR 7 tarafından gönderildi Mesajı Görüntüle
hocam bu kodlar, herhangi bir geri dönüş yapmak istediğimizde "ctrl+z" ye izin verebilir mi?
Ek dosyayı deneyin, geri alma işleminde hata ile karşılaşırsanız, variant yerine
bir yardımcı sütun veya sayfa ile yaparız
http://s3.dosya.tc/server13/9nmcsy/Deneme2.zip.html
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Application.CutCopyMode = 0 Then Call deg
End Sub
ilgili sayfa kodları
Private Sub Worksheet_Change(ByVal Target As Range)
If mr <> Empty Then Exit Sub
If Selection.Cells.Count <> 1 Then Exit Sub
If Intersect(Target, [B:I]) Is Nothing Then Exit Sub
If Target.Value = "" Then Exit Sub
Application.EnableEvents = False
If WorksheetFunction.CountIf(Range("B" & Target.Row & ":I" & Target.Row), "") < 7 Then
MsgBox "Bu satırda zaten veri var"
Target.Value = ""
Application.EnableEvents = True
Exit Sub
End If
With Range("B" & Target.Row & ":I" & Target.Row)
.ClearFormats
.Value = ""
End With
Range("A" & Target.Row & ":I" & Target.Row).Borders.Weight = xlThin
Cells(1, Target.Column).Copy Target
Application.EnableEvents = True
End Sub
modül1
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)

Sub kes_kopya()
'If Selection.Cells.Count > 1 Then
If Intersect(ActiveCell, [B:I]) Is Nothing Or Application.CutCopyMode = 0 Then Exit Sub
ActiveSheet.Paste
For Each j In Selection.Cells
If j.Row = 1 Then MsgBox "Kes-kopyala 2.satırdan itibaren olmalıdır": Application.CutCopyMode = False: Exit Sub
If j.Value <> "" Then
x = j.Address
With Range("B" & j.Row & ":I" & j.Row)
.ClearFormats
.Value = ""
End With
Cells(1, j.Column).Copy Range(x)
 Range(mr).Borders.Weight = xlThin 'bu satır hata verirse silip, alt satırı kullanın
'Range("B" & j.Row & ":I" & j.Row).Borders.Weight = xlThin
End If
Next
'End If
End Sub
modül2
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Public m As Variant
Public mr As String
Sub deg()
mr = Empty
a = Selection.Cells.Row
b = Selection.Cells.Rows.Count + a - 1
m = Range("B" & a & ":I" & b).Value
mr = Range("B" & a & ":I" & b).Address
End Sub
Sub gerial()
If mr <> "" Then
With Range(mr)
.ClearFormats
.Value = ""
.Borders.Weight = xlThin
End With
Range(mr).Value = m
For Each j In Range(mr)
If j.Value <> "" Then Cells(1, j.Column).Copy j
Next
mr = Empty
End If
End Sub
PLİNT Çevrimdışı   Alıntı Yaparak Cevapla
Eski 04-01-2018, 14:46   #19
DMR 7
 
Giriş: 14/09/2017
Şehir: Ankara
Mesaj: 77
Excel Vers. ve Dili:
2010 / Tr
Varsayılan

Alıntı:
PLİNT tarafından gönderildi Mesajı Görüntüle
Ek dosyayı deneyin, geri alma işleminde hata ile karşılaşırsanız, variant yerine
bir yardımcı sütun veya sayfa ile yaparız
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
 Range(mr).Borders.Weight = xlThin 'bu satır hata verirse silip, alt satırı kullanın
'Range("B" & j.Row & ":I" & j.Row).Borders.Weight = xlThin
sadece dediğiniz satır hata verdi onu da aşağıdakini kullanarak hallettim.

hata vermiyor hocam ama geri almıyor.
DMR 7 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 05-01-2018, 08:22   #20
PLİNT
 
Giriş: 31/12/2014
Şehir: Gürün
Mesaj: 1,322
Excel Vers. ve Dili:
Excel 2010
Varsayılan

Alıntı:
DMR 7 tarafından gönderildi Mesajı Görüntüle
sadece dediğiniz satır hata verdi onu da aşağıdakini kullanarak hallettim.
hata vermiyor hocam ama geri almıyor.
Merhaba
Kopyalamadan sonra yapılan yapıştırma esnasında kayda aldığı için geri alma işlemi zorluk çıkaracaktır.
Ekte biri yardımcı sayfa ile yapılmış iki dosya bulunuyor
http://s3.dosya.tc/server13/zk52yi/Denemeler.zip.html
PLİNT Çevrimdışı   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 18:42


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Web Tasarım -- Beylikdüzü mali müşavir - Lingerie - Dyeing Machine - Karton Bardak- Karton Bardak- Çorlu Dil Konuşma Terapisti- Çorlu Özel Eğitim- Site Yönetimi- Pronet Tekirdağ- Çorlu Kamera- Pronet Edirne- Pronet Çorlu- Çorlu Araç Takip- Çorlu Su Arıtma- Gebze Emlak- Rampa- Rotary- Çorlu İnternet Sitesi- Çorlu Sürücü Kursu- Çorlu Sürücü Kursu- Şişli Avukat- Edirne Serbest Muhasebeci- Çorlu Etüt- İstanbul Botanik- Çorlu Sigorta- Kağıt Bardak- Kaplan Tekstil- Çorlu Perde- Çorlu Havuz- Makina- Danışmazlar-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden