Belirli hücrelerin resmini alip masaüstüne kaydetme

[tcncsgo10]

Merhaba arkadaşlar

SONUC adında bir sayfam var bir makro butonuna basıldığında A1:G17 aradındaki hücreleri masaüstünde resim adlı klasöre resim olarak kaydetmek ve yine sonuç sayfasındaki A1:N1 arasındaki hücreleride Exceldeki KAYIT adındaki sayfama göndermek istiyorum.

Ancak butona her tıklamamda yeni resim oluşturmalı 1-2-3-4 gibi kayıt sayfasında da her kayıt ta alt alta kaydetmesi gerekiyor

Tek bir makro kodu ile mümkün olabilir mi?

 

[Necdet]

Merhaba,
Sorunuzu chat gpt ye sordum yanıtını buraya ekliyorum. Ben denemedim, siz dener sonucu belirtirsiniz.

Sub ExportAndSaveData()
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim wsSonuc As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim lastRow As Long
    Dim imgPath As String
    Dim imgName As String
    Dim imgNumber As Integer
    
    ' Set worksheets
    Set wsSonuc = ThisWorkbook.Sheets("SONUC")
    Set wsTarget = ThisWorkbook.Sheets("KAYIT")
    
    ' Set ranges
    Set rng1 = wsSonuc.Range("A1:G17")
    Set rng2 = wsSonuc.Range("A1:N1")
    
    ' Define image path
    imgPath = Environ("USERPROFILE") & "\Desktop\resim\"
    
    ' Create directory if not exist
    If Dir(imgPath, vbDirectory) = "" Then
        MkDir imgPath
    End If
    
    ' Generate image name
    imgNumber = 1
    Do While Dir(imgPath & "resim" & imgNumber & ".png") <> ""
        imgNumber = imgNumber + 1
    Loop
    imgName = imgPath & "resim" & imgNumber & ".png"
    
    ' Copy range as picture and save
    rng1.CopyPicture xlScreen, xlPicture
    With wsSonuc.ChartObjects.Add(0, 0, rng1.Width, rng1.Height)
        .Chart.Paste
        .Chart.Export Filename:=imgName, FilterName:="PNG"
        .Delete
    End With
    
    ' Find last row in KAYIT sheet
    lastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1
    
    ' Copy data from SONUC to KAYIT
    rng2.Copy wsTarget.Range("A" & lastRow)
    
    ' Inform user
    MsgBox "Data has been exported successfully!", vbInformation
End Sub

 

[tcncsgo10]

Merhaba,
Sorunuzu chat gpt ye sordum yanıtını buraya ekliyorum. Ben denemedim, siz dener sonucu belirtirsiniz.

Sub ExportAndSaveData()
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim wsSonuc As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim lastRow As Long
    Dim imgPath As String
    Dim imgName As String
    Dim imgNumber As Integer
  
    ' Set worksheets
    Set wsSonuc = ThisWorkbook.Sheets("SONUC")
    Set wsTarget = ThisWorkbook.Sheets("KAYIT")
  
    ' Set ranges
    Set rng1 = wsSonuc.Range("A1:G17")
    Set rng2 = wsSonuc.Range("A1:N1")
  
    ' Define image path
    imgPath = Environ("USERPROFILE") & "\Desktop\resim\"
  
    ' Create directory if not exist
    If Dir(imgPath, vbDirectory) = "" Then
        MkDir imgPath
    End If
  
    ' Generate image name
    imgNumber = 1
    Do While Dir(imgPath & "resim" & imgNumber & ".png") <> ""
        imgNumber = imgNumber + 1
    Loop
    imgName = imgPath & "resim" & imgNumber & ".png"
  
    ' Copy range as picture and save
    rng1.CopyPicture xlScreen, xlPicture
    With wsSonuc.ChartObjects.Add(0, 0, rng1.Width, rng1.Height)
        .Chart.Paste
        .Chart.Export Filename:=imgName, FilterName:="PNG"
        .Delete
    End With
  
    ' Find last row in KAYIT sheet
    lastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1
  
    ' Copy data from SONUC to KAYIT
    rng2.Copy wsTarget.Range("A" & lastRow)
  
    ' Inform user
    MsgBox "Data has been exported successfully!", vbInformation
End Sub

Chatcpt kod yazabiliyor mu?

 

[Necdet]

bir tek yemek yapamıyor

 

[Muhammet Okumuş]

İyi günler Necdet Bey. Kod resmin olmadığı sayfalarda kayıt ediyor. Ama sayfada resim (jpeg) varsa boş resim olarak kaydediyor.