Merhaba arkadaşlar elimde bir kod var kod sorunsuz olarak Excel'de ki sayfayı masaüstündeki klasöre kaydediyor ancak göründüğü şekilde değil boş beyaz bir sayfa olarak kaydediyor kodun neresinde hata var?
Bu kod Excel 2016'da çalışmıyor
Bu kod Excel 2016'da çalışmıyor
Kod:
Sub SaveRangeAsImageAndAppendData()
Dim ws As Worksheet
Dim rng As Range
Dim chartObj As ChartObject
Dim filePath As String
Dim imgFileName As String
Dim cellA2 As String
Dim cellI2 As String
Dim recordSheet As Worksheet
Dim dataRange As Range
Dim cell As Range
Dim recordRow As Long
Dim lastRow As Long
' Sayfa2'yi referans olarak al
Set ws = ThisWorkbook.Sheets("Sayfa2")
' A2 ve I2 hücrelerinin içeriğini al
cellA2 = ws.Range("A2").Value
cellI2 = ws.Range("I2").Value
' Dosya adı oluştur
imgFileName = cellA2 & "_" & cellI2 & ".jpg"
filePath = Environ("USERPROFILE") & "\Desktop\Resim\" & imgFileName
' A1:AQ19 aralığını seç
Set rng = ws.Range("A1:AQ19")
' Geçici bir grafik oluştur
Set chartObj = ws.ChartObjects.Add(Left:=rng.Left, Width:=rng.Width, Top:=rng.Top, Height:=rng.Height)
chartObj.Chart.ChartArea.Format.Line.Visible = msoFalse ' Kenarlıkları kaldır
chartObj.Chart.PlotArea.Format.Line.Visible = msoFalse ' Çizgi kaldır
' Aralığı resim olarak kopyala
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
chartObj.Chart.Paste
chartObj.Chart.Export fileName:=filePath, FilterName:="JPEG"
' Grafik nesnesini temizle
chartObj.Delete
' Kayıt sayfasını oluştur veya aç
On Error Resume Next
Set recordSheet = ThisWorkbook.Sheets("Kayıt")
On Error GoTo 0
If recordSheet Is Nothing Then
Set recordSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
recordSheet.Name = "Kayıt"
End If
' Sonraki boş satırı bul
lastRow = recordSheet.Cells(recordSheet.Rows.Count, 1).End(xlUp).Row + 1
' A19:AQ19 hücrelerini alt alta şekilde kaydet
Set dataRange = ws.Range("D19:AF19")
For Each cell In dataRange
recordSheet.Cells(lastRow, 1).Value = cell.Value
lastRow = lastRow + 1
Next cell
' Kullanıcıya bilgi ver
MsgBox "Resim kaydedildi: " & filePath & vbCrLf & "Veri 'Kayıt' sayfasına eklendi."
End Sub
Son düzenleme:
