Resimli fiyat listesi sorun

[neka75]

Arkadaşlar aşşağıdaki kod ile fiyat teklifini resimli olarak hazırlıyorum,
d ütünuna değerleri giriyorum e sütununda resimler çıkıyor,

herhangi bir hücreye değer girip enter yapınca g10 hücresi otomatik seçiliyor

bunu iptal edebilirmiyiz,

hücre değerini girip enter yapınca seçim bi alt hücreye geçebilir mi ??

yardımlarınız için şimdiden teşekkürler

Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.DrawingObjects.Delete
For x = 14 To 27
Range("D" & x).Select
resimadi = LoadPicture("")
resimadi = Range("E" & x).Text & ".PNG"
On Error Resume Next
ActiveSheet.Pictures.Insert("D:\Documents and Settings\AAA\Desktop\resimli\" & resimadi).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 68 'yükseklik
Selection.ShapeRange.Width = 97 'genişlik
Selection.ShapeRange.Rotation = 0#
Range("G10").Select
Next
End Sub

 

[forever215]

Merhaba kodunuzun sondan üçüncü satırı olan Range("G10").Select kodunuzu silerseniz sorun ortadan kalkar.

 

[neka75]

denedim fakat olmuyor, o zaman da D27 YE GİDİYOR

 

[Emir Hüseyin Çoban]

. . .

private sub worksheet_change(byval target as range)
aa = selection.address
activesheet.drawingobjects.delete
for x = 14 to 27
range("d" & x).select
resimadi = loadpicture("")
resimadi = range("e" & x).text & ".png"
on error resume next
activesheet.pictures.ınsert("d:\documents and settings\aaa\desktop\resimli\" & resimadi).select
selection.shaperange.lockaspectratio = msofalse
selection.shaperange.height = 68 'yükseklik
selection.shaperange.width = 97 'genişlik
selection.shaperange.rotation = 0#
'range("g10").select
range(aa).select
next
end sub

. . .

 

[neka75]

Teşekkürler

Elinize sağlık çok teşekkürler, şimdi istediğim gibi oldu,


eğer kullanmak isteyen olursa diye
dosyayının sonhalini ekte gönderiyorum,

 

[neka75]

resimli fiyat teklif formu ilave

Yukarıdaki dosyada değişiklik yapabilirmiyiz,


- kodda "D:\Documents and Settings\AAA\Desktop\resimli\" , resimlerin olduğu klasör var bunu farklı bilgisayarda kullanınca değişiklik yapmak gerekiyor,
bunu düzeltebilirmiyiz,

- farklı bir makro ile sayfadaki teklif sayfasını ayrı bir dosya olarak otomatik kayıt edebilirmiyiz,
data olan sayfa ya gerek yok,

daha önce aşşağıdaki kodu buna benzer bir uygulama için kullanmıştım,
fakat aynı şekilde uygulama yapınca hata veriyor,

Option Explicit

Sub TwoSheetsAndYourOut()
Dim NewName As String
Dim nm As Name
Dim ws As Worksheet

If MsgBox("Bu dosyayı kayıt etmek istiyormusunuz?" & vbCr & _
"" _
, vbYesNo, "Uyarı") = vbNo Then Exit Sub

With Application
.ScreenUpdating = False

' Copy specific sheets
' *SET THE SHEET NAMES TO COPY BELOW*
' Array("Sheet Name", "Another sheet name", "And Another"))
' Sheet names go inside quotes, seperated by commas
On Error GoTo ErrCatcher
Sheets(Array("packinglist", "proforma")).Copy
On Error GoTo 0

' Paste sheets as values
' Remove External Links, Hperlinks and hard-code formulas
' Make sure A1 is selected on all sheets
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Copy
ws.Cells.PasteSpecial Paste:=xlValues
ws.Cells.Hyperlinks.Delete
Application.CutCopyMode = True
Cells(1, 1).Select
ws.Activate
Next ws
Cells(1, 1).Select

' Remove named ranges
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm

' Input box to name new file
NewName = Sheets("proforma").Range("J1")

' Save it with the NewName and in the same directory as original
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xls"
ActiveWorkbook.Close SaveChanges:=False

.ScreenUpdating = True
End With
Exit Sub

ErrCatcher:
MsgBox "Specified sheets do not exist within this workbook"
End Sub


örnek dosya aşşağıdaki linke yüklemiştim.
http://www.excel.web.tr/f130/ihracat-proforma-ve-ceki-listesi-hazyrlama-t109202.html