resim kes yapıştır.

euphrates55 · 23 Mart 2019

makro ile resim kes yapıştır nasıl yapılır. aşağıdaki kod ile olmuyor.

Kod:

Sub Makro1()
ActiveSheet.Shapes("Picture 5").Select
Selection.Cut
Range("I7:T20").Select
ActiveSheet.Paste
End Sub

PLİNT · 24 Mart 2019

Merhaba
Kodlardaki "selection.copy" yerine "selection.cut" şeklinde denedinizmi?

euphrates55 · 24 Mart 2019

PLİNT' Alıntı:
Merhaba
Kodlardaki "selection.copy" yerine "selection.cut" şeklinde denedinizmi?

evet. hatta makro kaydedip çalıştırdım ama hata veriyor

Tapatalk kullanarak iPhone aracılığıyla gönderildi

PLİNT · 24 Mart 2019

Resim adında değişiklik yoksa hata vermemesi gerek, yapıştırma ile ismin değiştiğine dikkat ediniz

euphrates55 · 24 Mart 2019

Kod:

    Range("B15:J16").Select
    ActiveSheet.Shapes.Range(Array("Picture 4")).Select
    Selection.Cut
    Range("K15:S15").Select
    ActiveSheet.Pictures.Paste.Select

resimi klasörden çağırıyor. sanırım oradan farkediyor. bu şekilde çözdüm. aynı hücre içinde yaptığım için resim eskisi gibi tam oturmuyor hücreye. bunu da çözmem gerek

aslında olay tam olarak şu şekilde. makro ile klasöreden resim alıyorum. aldığım sayfayı başka bir bilgisayarda açarken resimler çıkmıyor. ben de kod da bu şekilde çözmeye çalışıyorum. kes resim olarak yapıştır. şimdi sıra k15:s15 e tam olarak oturtmak.

Ömer BARAN · 24 Mart 2019

Merhaba.
Ben de sayfaya, EKLE>>RESİMLER >> yöntemiyle bir resim ekledikten sonra kodu çalıştırdığımda
resim adında değişiklik de olmadan kes-yapıştır işlemi gerçekleşiyor durumda.
Eklenen resimin adı Excel dili dolayısıyla formül çubuğunun solunda "Resim 1" olarak görünse de aşağıdaki şekilde sonuç aldım.

CSS:

Sub Makro1()
    ActiveSheet.Shapes("Picture 1").Cut
    [A1].Activate: ActiveSheet.Paste: [A1].Activate
End Sub

Seyit Tiken · 24 Mart 2019

Birde bu şekilde bir deneyiniz.

Kod:

ActiveSheet.Shapes("Picture 4").Cut
[K15].Select
ActiveSheet.Pictures.Paste

euphrates55 · 24 Mart 2019

Kod:

ActiveSheet.Shapes("Picture 4").Cut
[K15].Select
ActiveSheet.Pictures.Paste.Select

bu şekilde halloldu. başka bir sorunum çıktı. bu şekilde bir çok excel sayfasını birleştiriyorum. fakat bazılarında resim yok ve dolayısı ile hata veriyor. ben bu koda resim yoksa takılma nasıl derim.
bir diğer sorum ise ki aslında ben bunu önceki yaptığım işlemde yapıp resimi orada kesip yapıştırtmak istiyordum. fakat her bir resim farklı numara aldığı için birleştirirken yapmak daha kolay oldu. hepsi picture 4 olarak yerleşiyor. resimlerin numaralarından değilde başka türlü tanımlatmak mümkün mü. buna göre şekillendireceğim kendimi... teşekkürler herkese

halit3 · 24 Mart 2019

Alternatif olarak birde bu kodu dene
bu kod sayfa üzerindeki en son eklenen resim nesnesini keser

Kod:

say = ActiveSheet.Shapes.Count
If say > 0 Then
For k = say To 1 Step -1
If ActiveSheet.Shapes(k).Type = 13 Then
ActiveSheet.Shapes(k).Cut
[K15].Select
ActiveSheet.Pictures.Paste.Select
Exit Sub
End If
Next k
End If

euphrates55 · 24 Mart 2019

halit3' Alıntı:
Alternatif olarak birde bu kodu dene
bu kod sayfa üzerindeki en son eklenen resim nesnesini keser

Kod:

say = ActiveSheet.Shapes.Count If say > 0 Then For k = say To 1 Step -1 If ActiveSheet.Shapes(k).Type = 13 Then ActiveSheet.Shapes(k).Cut [K15].Select ActiveSheet.Pictures.Paste.Select Exit Sub End If Next k End If

birden fazla resim olan raporlarım da var. sonrasında bunlara da uygulayacağım. resim bulamazsan atla kodu şu an daha çok işime yarayacaktır

Tapatalk kullanarak iPhone aracılığıyla gönderildi

halit3 · 24 Mart 2019

euphrates55' Alıntı:
birden fazla resim olan raporlarım da var. sonrasında bunlara da uygulayacağım. resim bulamazsan atla kodu şu an daha çok işime yarayacaktır

Tapatalk kullanarak iPhone aracılığıyla gönderildi

Kod sayfada resim olmaz ise işlem yapmayacaktır.

euphrates55 · 24 Mart 2019

halit3' Alıntı:
Kod sayfada resim olmaz ise işlem yapmayacaktır.

eyvah. çözüm yok yani öyle mi. resim 4 varsa kes yapıştır yoksa atla diye bir kod olmuyor mu

Tapatalk kullanarak iPhone aracılığıyla gönderildi

halit3 · 24 Mart 2019

o zaman bunu dene kırmızı yere resim adını yazınız bu isimde resim varsa işlem yapacak yoksa işlem yapmayacak

Rich (BB code):

say = ActiveSheet.Shapes.Count
If say > 0 Then
For k = 1 To say
If ActiveSheet.Shapes(k).Type = 13 Then
If ActiveSheet.Shapes(k).Name = "resim 4" Then
ActiveSheet.Shapes(k).Cut
[K15].Select
ActiveSheet.Pictures.Paste.Select
End If
End If
Next k
End If

halit3 · 24 Mart 2019

Ama Bu bölümde
ActiveSheet.Shapes(k).Cut
[K15].Select
ActiveSheet.Pictures.Paste.Select
resim adı hep değişecektir bilgilerinize

euphrates55 · 24 Mart 2019

halit3' Alıntı:
Ama Bu bölümde
ActiveSheet.Shapes(k).Cut
[K15].Select
ActiveSheet.Pictures.Paste.Select
resim adı hep değişecektir bilgilerinize

doğru yere yazdıysaam olmadı. ben size tam kodu göndereyim en iyisi.

Kod:

Public bekle
Sub GetSheets()
bekle = "dur"

MsgBox "BİRLEŞTİRME İÇİN, BU DOSYANIN OLDUĞU DİZİNDE (İHALELER)- ADLI KLASÖRÜN OLMALI VE TÜM BİRLEŞECEK EXCEL DOSYALARIN BU KLASÖRDE OLMALI ", vbExclamation, "FIRAT UYARIYOR!"
Secim = MsgBox("BU ŞARTLAR SAĞLANDI MI?", vbYesNo + vbCritical, "İYİ DÜŞÜN")
If Secim = vbYes Then
Application.Visible = True
ElseIf Secim = vbNo Then
MsgBox "PEKİ, İPTAL EDELİM O HALDE!", vbMsgBoxSetForeground
Exit Sub

End If

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
Path = ThisWorkbook.Path & "\İHALELER\"
Filename = Dir(Path & "*.xlsx")
  Do While Filename <> ""
  Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
     For Each Sheet In ActiveWorkbook.Sheets
     ActiveSheet.Hyperlinks.Delete
ActiveSheet.Shapes("Picture 4").Cut
[K15].Select
ActiveSheet.Pictures.Paste.Select


say = ActiveSheet.Shapes.Count
If say > 0 Then
For k = 1 To say
If ActiveSheet.Shapes(k).Type = 13 Then
If ActiveSheet.Shapes(k).Name = "resim 4" Then
ActiveSheet.Shapes(k).Cut
[K15].Select
ActiveSheet.Pictures.Paste.Select
End If
End If
Next k
End If

     ActiveSheet.Name = ActiveSheet.Range("v1")
     Sheet.Copy After:=ThisWorkbook.Sheets(1)
  Next Sheet
     Workbooks(Filename).Close
     Filename = Dir()
     Dim wb As Workbook
Set wb = Application.ActiveWorkbook
If Not IsEmpty(wb.LinkSources(xlExcelLinks)) Then
    For Each link In wb.LinkSources(xlExcelLinks)
        wb.BreakLink link, xlLinkTypeExcelLinks
    Next link
End If
  Loop
bekle = ""
MsgBox "Birleştirme Tamamlandı", vbInformation
End Sub

hem fazlalık kod varsa silersiniz belki

halit3 · 24 Mart 2019

Gördüğüm kadarı ile böyle olur belkide
kırmız bölümde resim 4 nesnesinin adı değişiyor haberiniz olsun dosyayı bir daha açtığınızda aynı kodu çalıştırdığınızda resim 4 nesnesi olmayacak

Rich (BB code):

Public bekle
Sub GetSheets()
bekle = "dur"

MsgBox "BİRLEŞTİRME İÇİN, BU DOSYANIN OLDUĞU DİZİNDE (İHALELER)- ADLI KLASÖRÜN OLMALI VE TÜM BİRLEŞECEK EXCEL DOSYALARIN BU KLASÖRDE OLMALI ", vbExclamation, "FIRAT UYARIYOR!"
Secim = MsgBox("BU ŞARTLAR SAĞLANDI MI?", vbYesNo + vbCritical, "İYİ DÜŞÜN")
If Secim = vbYes Then
Application.Visible = True
ElseIf Secim = vbNo Then
MsgBox "PEKİ, İPTAL EDELİM O HALDE!", vbMsgBoxSetForeground
Exit Sub

End If

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
Path = ThisWorkbook.Path & "\İHALELER\"
Filename = Dir(Path & "*.xlsx")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
ActiveSheet.Hyperlinks.Delete

say = ActiveSheet.Shapes.Count
If say > 0 Then
For k = 1 To say
If ActiveSheet.Shapes(k).Type = 13 Then
If ActiveSheet.Shapes(k).Name = "resim 4" Then
ActiveSheet.Shapes(k).Cut
[K15].Select
ActiveSheet.Pictures.Paste.Select
End If
End If
Next k
End If


Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Dim wb As Workbook
Set wb = Application.ActiveWorkbook
If Not IsEmpty(wb.LinkSources(xlExcelLinks)) Then
For Each link In wb.LinkSources(xlExcelLinks)
wb.BreakLink link, xlLinkTypeExcelLinks
Next link
End If
Loop
bekle = ""
MsgBox "Birleştirme Tamamlandı", vbInformation
End Sub

halit3 · 24 Mart 2019

Bana kalırsa siz resim 4 ü K15 hücresine getirmek istiyorsunuz durum böyle is bu kodu kullanın

Rich (BB code):

Public bekle
Sub GetSheets()
bekle = "dur"

MsgBox "BİRLEŞTİRME İÇİN, BU DOSYANIN OLDUĞU DİZİNDE (İHALELER)- ADLI KLASÖRÜN OLMALI VE TÜM BİRLEŞECEK EXCEL DOSYALARIN BU KLASÖRDE OLMALI ", vbExclamation, "FIRAT UYARIYOR!"
Secim = MsgBox("BU ŞARTLAR SAĞLANDI MI?", vbYesNo + vbCritical, "İYİ DÜŞÜN")
If Secim = vbYes Then
Application.Visible = True
ElseIf Secim = vbNo Then
MsgBox "PEKİ, İPTAL EDELİM O HALDE!", vbMsgBoxSetForeground
Exit Sub

End If

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False



Path = ThisWorkbook.Path & "\İHALELER\"
Filename = Dir(Path & "*.xlsx")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
ActiveSheet.Hyperlinks.Delete

Set Adres1 = ActiveSheet.Cells(15, "k")
Say = ActiveSheet.Shapes.Count
If Say > 0 Then
For k = 1 To Say
If ActiveSheet.Shapes(k).Type = 13 Then
If ActiveSheet.Shapes(k).Name = "resim 4" Then
ActiveSheet.Shapes(ActiveSheet.Shapes(k).Name).OLEFormat.Object.Top = Adres1.Top + 1
ActiveSheet.Shapes(ActiveSheet.Shapes(k).Name).OLEFormat.Object.Left = Adres1.Left + 1
End If
End If
Next k
End If

Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Dim wb As Workbook
Set wb = Application.ActiveWorkbook
If Not IsEmpty(wb.LinkSources(xlExcelLinks)) Then
For Each link In wb.LinkSources(xlExcelLinks)
wb.BreakLink link, xlLinkTypeExcelLinks
Next link
End If
Loop
bekle = ""
MsgBox "Birleştirme Tamamlandı", vbInformation
End Sub

euphrates55 · 24 Mart 2019

iki koduda denedim ama olmuyor. kod çalışıyor ve resim olmayanlara sıkıntı çıkarmıyor. bu tamam fakat benim işimi çözmüyor. çünkü resimleri yine benim bilgisayarımdan kullanıyor. o yüzden bu resim ya da her ne oluyorsa artık, kesip resim olarak tekrar yapıştırıyorum

olayın aslını tekrar anlatayım. bir formum var ve bu form üzerinden oluşturduğum bir listeyi tek tek seçerek her iş için ayrı bir excel sayfası çıkarıyorum. buradaki resimleri de ilgili klasörlerden alıyor. benim bilgisayarımda açtığımda tüm resimler yerli yerinde fakat başkasına gönderdiğimde resimler çıkmıyor. ben de bu olayı aşabilmek için ilgili hücreye çağırılan resmi kesip resim olarak yapıştırmak istiyorum. böylece kaydettiğimde resimler başka bilgisayarlarda da gözükebiliyor.

son kodunuzda kes yok sanırım. yani olayım resmi yerleştirmek değil. zaten aynı hücrede olan resmi kesip resim olarak yapıştırıyorum.

euphrates55 · 24 Mart 2019

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("V3")) Is Nothing Then Exit Sub
On Error Resume Next
Dim resim As Object, i As Long, yol As String, dosya As String
Sheets("Sunu").Select
yol = ThisWorkbook.Path & "\GEREKLİDOSYALAR" & "\" & "haritalar\"

Rem aralıktaki resmi sil
Set alan = Range("k15:s15")
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, alan) Is Nothing Then
resimm.Delete
End If
Next
Set alan = Nothing
Rem silme işleminin sonu

If Dir(yol & "\" & Cells(1, "V").Value & ".png") <> "" Then
dosya = "\" & Cells(1, "V").Value & ".png"
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)
With Cells(15, "k")
t = .Top
l = .Left
W = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With
With P
.ShapeRange.LockAspectRatio = msoFalse
.Top = t + 1
.Left = l + 1
.Width = W - 2
.Height = h - 2
End With
Set P = Nothing
End If

belki burada çözülebilir mi? resimi ekledikten sonra kes yapıştır olabilir mi? buraya eklenecek kod ile eklenen resimi kes ve yapıştır gibi.

halit3 · 24 Mart 2019

siz en iyisi kod yerine dosyalarınızdan küçük birer örnek buraya ekleyin bir bakalım.

resim kes yapıştır.

euphrates55

PLİNT

euphrates55

PLİNT

euphrates55

Ömer BARAN

Uzman

Seyit Tiken

Uzman

euphrates55

halit3

Uzman

euphrates55

halit3

Uzman

euphrates55

halit3

Uzman

halit3

Uzman

euphrates55

halit3

Uzman

halit3

Uzman

euphrates55

euphrates55

halit3

Uzman