exeldeki veriyi worde aktarmak için kod düzeltme

[akumert]

Sub ExportToWord()
Dim wdApp As Object
Dim wdDoc As Object
Dim ws As Worksheet
Dim tblRange As Range
Dim filledRows As Collection
Dim tbl As Object
Dim i As Long, j As Long
Dim maxCols As Long

' Çalışma sayfasını ayarla
On Error Resume Next
Set ws = ThisWorkbook.Sheets("1 İHALE KARARI")
On Error GoTo 0

If ws Is Nothing Then
MsgBox "1 İHALE KARARI adında bir çalışma sayfası bulunamadı. İşlem iptal edildi."
Exit Sub
End If

' Word uygulamasını başlat
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If wdApp Is Nothing Then
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0

wdApp.Visible = True
Set wdDoc = wdApp.Documents.Add

' V110 hücresindeki metni Word'e ekle
If ws.Range("V110").Value <> "" Then
wdDoc.Content.Text = ws.Range("V110").Value & vbCrLf
Else
MsgBox "V110 hücresi boş. İşlem iptal edildi."
Exit Sub
End If

' V111:X169 aralığındaki dolu satırları tabloya ekle
Set tblRange = ws.Range("V111:X169")

' Dolu satırları topla
Set filledRows = New Collection
For i = 1 To tblRange.Rows.Count
Dim isRowEmpty As Boolean
isRowEmpty = True

' Satırdaki her hücreyi kontrol et
For j = 1 To tblRange.Columns.Count
If Not IsEmpty(tblRange.Cells(i, j).Value) Then
isRowEmpty = False
Exit For ' Eğer bir hücre doluysa satır boş sayılmaz
End If
Next j

' Eğer satırda hiç boş olmayan hücre varsa, satırı ekle
If Not isRowEmpty Then
filledRows.Add tblRange.Rows(i)
End If
Next i

' Eğer dolu satır yoksa tabloyu oluşturma
If filledRows.Count > 0 Then
maxCols = tblRange.Columns.Count
Set tbl = wdDoc.Tables.Add(wdDoc.Bookmarks("\EndOfDoc").Range, filledRows.Count, maxCols)

' Dolu satırları tabloya aktar
For i = 1 To filledRows.Count
For j = 1 To maxCols
tbl.Cell(i, j).Range.Text = filledRows(i).Cells(1, j).Value
Next j
Next i
End If

' Tablo altına V170 hücresindeki metni ekle
If ws.Range("V170").Value <> "" Then
wdDoc.Bookmarks("\EndOfDoc").Range.InsertParagraphAfter
wdDoc.Bookmarks("\EndOfDoc").Range.Text = ws.Range("V170").Value & vbCrLf
End If

' V170 metni altına V171 hücresindeki metni ekle
If ws.Range("V171").Value <> "" Then
wdDoc.Bookmarks("\EndOfDoc").Range.InsertParagraphAfter
wdDoc.Bookmarks("\EndOfDoc").Range.Text = ws.Range("V171").Value
End If

' İşlem tamamlandı
MsgBox "Veriler başarıyla Word belgesine aktarıldı!"
End Sub

böyle bir kod var çalışıyor fakat veriyi worde aktarırken arada oluşturduğu tablonun boş olan hücrelerini de getiriyor benim istediğim ise tablo oluşturduğu alandaki boş hücreleri tabloya dahil etmemesi yadırmcı olursanız sevinirim

 

[necati]

Merhaba, verilerinizde formül sonucu sıfır değeri varsa veya boşluk basılı ise o satırlar dolu olarak algılanır.
Böyle bir durum varsa şu satırı değiştirip deneyebilirsiniz:
If Not IsEmpty(tblRange.Cells(i, j).Value) Then

Bununla değiştiriniz
If tblRange.Cells(i, j).Value <> 0 And tblRange.Cells(i, j).Value <> "" And tblRange.Cells(i, j).Value <> " " Then