Yardım Excell hücresinin resim olarak kaydetme vba kod yazarak.

dead001

Yeni Üye
Katılım
29 Ağu 2019
Mesajlar
11
En iyi yanıt
0
Puanları
1
Yaş
34
Konum
bursa
Ad Soyad
osman bektaş
Sub tümhücre()

For i = 2 To 400

Range("D2:F2").Select
Selection.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
Range("G2").Paste

Next i
End Sub
Bu kodu makro kaydederek aldım . for Next döngüsüyle tüm sayfaya nasıl uygulayabilirim .Teşekkürler
 

ozkansabanci

Excel VBA Developer
Uzman
Katılım
28 May 2018
Mesajlar
82
En iyi yanıt
2
Puanları
18
Yaş
33
Konum
Kocaeli
Web sitesi
www.ozkansabanci.com
Ad Soyad
Özkan Sabancı
Sub tümhücre()

For i = 2 To 400

Range("D2:F2").Select
Selection.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
Range("G2").Paste

Next i
End Sub
Bu kodu makro kaydederek aldım . for Next döngüsüyle tüm sayfaya nasıl uygulayabilirim .Teşekkürler
Tam olarak yapılmak istenen nedir?
 

dead001

Yeni Üye
Katılım
29 Ağu 2019
Mesajlar
11
En iyi yanıt
0
Puanları
1
Yaş
34
Konum
bursa
Ad Soyad
osman bektaş
D2 ile f2 hücresini sayfaya resim olarak kaydetme istiyorum . Bunu ortadaki kod ile yapıyorum. Ama aşağıya doğru diğer hücrelerinde resimlerini kaydetmesini istiyorum .d3;f3 d4;f4 ... vs
 

muygun

Uzman
Katılım
19 Ağu 2018
Mesajlar
60
En iyi yanıt
6
Puanları
8
Konum
Konya-Ankara
Ad Soyad
Mustafa UYGUN
Merhaba;
Alternatif olsun (kodlar alıntıdır)
Boş bir modüle;

Sub jpg_kaydet()
Application.ScreenUpdating = False
On Error Resume Next
Dim objTemp As Object
Dim chtMyChart As Chart
Dim rngImg As Range
Dim No As Long
Dim TempName As String
For i = 2 To 400
If Cells(i, "d") <> "" Then
Set rngImg = Range("d" & i & ":f" & i) 'resim alanı
rngImg.Copy
Set objTemp = ActiveSheet.Shapes.AddShape(1, 1, 1, 1, 1)
objTemp.Select
ActiveSheet.Paste
objTemp.Delete
TempName = ThisWorkbook.Path & "\" & i & ".jpg"
With Selection
.CopyPicture 1, 2
Set chtMyChart = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
chtMyChart = ShapeRange.Line.Visible = msoFalse
With chtMyChart
.Paste
.Export TempName
.Parent.Delete
End With
.Delete
End With
Set rngImg = Nothing
Set objTemp = Nothing
End If
Next i
MsgBox ("İşlem Bitti.")
Application.ScreenUpdating = True
End Sub

Kodlarını ekleyip deneyin.
Dosyanın olduğu klasöre döngü adı ile (2,3,4.. vs) .jpg olarak kayıt yapar.
İyi çalışmalar.
 

dead001

Yeni Üye
Katılım
29 Ağu 2019
Mesajlar
11
En iyi yanıt
0
Puanları
1
Yaş
34
Konum
bursa
Ad Soyad
osman bektaş
Merhaba;
Alternatif olsun (kodlar alıntıdır)
Boş bir modüle;

Sub jpg_kaydet()
Application.ScreenUpdating = False
On Error Resume Next
Dim objTemp As Object
Dim chtMyChart As Chart
Dim rngImg As Range
Dim No As Long
Dim TempName As String
For i = 2 To 400
If Cells(i, "d") <> "" Then
Set rngImg = Range("d" & i & ":f" & i) 'resim alanı
rngImg.Copy
Set objTemp = ActiveSheet.Shapes.AddShape(1, 1, 1, 1, 1)
objTemp.Select
ActiveSheet.Paste
objTemp.Delete
TempName = ThisWorkbook.Path & "\" & i & ".jpg"
With Selection
.CopyPicture 1, 2
Set chtMyChart = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
chtMyChart = ShapeRange.Line.Visible = msoFalse
With chtMyChart
.Paste
.Export TempName
.Parent.Delete
End With
.Delete
End With
Set rngImg = Nothing
Set objTemp = Nothing
End If
Next i
MsgBox ("İşlem Bitti.")
Application.ScreenUpdating = True
End Sub

Kodlarını ekleyip deneyin.
Dosyanın olduğu klasöre döngü adı ile (2,3,4.. vs) .jpg olarak kayıt yapar.
İyi çalışmalar.
Kayıt yapıyor ama resimleri boş hücre çıkarıyor. Sorun nerede bulamadım
 

muygun

Uzman
Katılım
19 Ağu 2018
Mesajlar
60
En iyi yanıt
6
Puanları
8
Konum
Konya-Ankara
Ad Soyad
Mustafa UYGUN
Denediğim pc win7 32 bit ve ofis 2003
Ofis versiyon farkından olabilir.
Deneme şansınız varsa ofis 2003 yüklü bir pc de deneyin.
 

muygun

Uzman
Katılım
19 Ağu 2018
Mesajlar
60
En iyi yanıt
6
Puanları
8
Konum
Konya-Ankara
Ad Soyad
Mustafa UYGUN
Ofis 2010 da da çalıştı (sorun yok)
 

Ekli dosyalar

  • 2 KB Görüntüleme: 5
  • 2.5 KB Görüntüleme: 4

dead001

Yeni Üye
Katılım
29 Ağu 2019
Mesajlar
11
En iyi yanıt
0
Puanları
1
Yaş
34
Konum
bursa
Ad Soyad
osman bektaş
Office 2007 yüklüyorum orada bir deniyeceğim ,İlgilendiğiniz için teşekkür ederim.
 

dead001

Yeni Üye
Katılım
29 Ağu 2019
Mesajlar
11
En iyi yanıt
0
Puanları
1
Yaş
34
Konum
bursa
Ad Soyad
osman bektaş
Sub jpg_kaydet()
Application.ScreenUpdating = False
On Error Resume Next
Dim objTemp As Object
Dim chtMyChart As Chart
Dim rngImg As Range
Dim No As Long
Dim TempName As String
For i = 2 To 40
If Cells(i, "d") <> "" Then
Set rngImg = Range("d" & i & ":f" & i) 'resim alanı
rngImg.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
Set objTemp = ActiveSheet.Shapes.AddShape(1, 1, 1, 1, 1)
objTemp.Select
ActiveSheet.Paste
objTemp.Delete
TempName = ThisWorkbook.Path & "\" & Cells(i, "a") & Cells(i, "d") & ".jpg"
With Selection
.CopyPicture 1, 2
Set chtMyChart = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
chtMyChart = ShapeRange.Line.Visible = msoFalse
With chtMyChart
.Paste
.Export TempName
.Parent.Delete
End With
.Delete
End With
Set rngImg = Nothing
Set objTemp = Nothing
End If
Next i
MsgBox ("İşlem Bitti.")
Application.ScreenUpdating = True
End Sub
' Ben biraz değiştirdim istediğim hücrenin ismini resim ismi olarak kaydettirdim.
 

muygun

Uzman
Katılım
19 Ağu 2018
Mesajlar
60
En iyi yanıt
6
Puanları
8
Konum
Konya-Ankara
Ad Soyad
Mustafa UYGUN
Merhaba;
TempName = ThisWorkbook.Path & "\" & Cells(i, "a") & Cells(i, "d") & ".jpg"

Satırında ThisWorkbook.Path bulunduğu klasörü tanımlıyor.
Bunu "C:\resim" olarak değiştirirseniz C de resim klasörüne kayıt yapar
İyi çalışmalar.
 

dead001

Yeni Üye
Katılım
29 Ağu 2019
Mesajlar
11
En iyi yanıt
0
Puanları
1
Yaş
34
Konum
bursa
Ad Soyad
osman bektaş
Merhaba;
TempName = ThisWorkbook.Path & "\" & Cells(i, "a") & Cells(i, "d") & ".jpg"

Satırında ThisWorkbook.Path bulunduğu klasörü tanımlıyor.
Bunu "C:\resim" olarak değiştirirseniz C de resim klasörüne kayıt yapar
İyi çalışmalar.
Teşekkür ederim.
 
Üst Alt