Satırları birleştirerek aktarma

[NADİR YILDIZ]

arkadaşlar pdf dosyasını excel çevirdiğimde açıklamalar sütununu 2-3 satır olarak çeviriyor..bu açıklamaları tek satırda birleştirerek düzeltilmiş extre sayfasında örneklendirdiğim gibi nasıl aktarım yapabiliriz

iyi çalışmalar

 

[ÖmerFaruk]

Sub Düzelt()
    Set Sh1 = Worksheets("GELEN EXTRE")
    Set Sh2 = Worksheets("DÜZELTİLMİŞ EXTRE")
    k = 1
    For i = 2 To Sh1.Range("e1").End(xlDown).Row
        If InStr(1, Sh1.Range("E" & i), "Açıklama") > 0 Then GoTo SON
        k = k + 1
        Sh1.Range("A" & i, "H" & i).Copy
        Sh2.Range("A" & k, "H" & k).PasteSpecial xlValues
        If WorksheetFunction.CountA(Sh1.Range("A" & i, "D" & i), Sh1.Range("F" & i, "H" & i)) = 0 Then
            Sh1.Range("A" & i + 1, "H" & i + 1).Copy
            Sh2.Range("A" & k, "H" & k).PasteSpecial xlValues
            Sh2.Range("E" & k) = Sh1.Range("E" & i) & " " & Sh1.Range("E" & i + 1) & " " & Sh1.Range("E" & i + 2)
            If InStr(1, Sh2.Range("E" & k), Chr(10)) > 1 Then Sh2.Range("E" & k) = Replace(Sh2.Range("E" & k), Chr(10), "")
            i = i + 2
            GoTo Devam1
        End If
        If WorksheetFunction.CountA(Sh1.Range("A" & i + 1, "D" & i + 1), Sh1.Range("F" & i + 1, "H" & i + 1)) = 0 Then
            Sh2.Range("E" & k) = Sh2.Range("E" & k) & " " & Sh1.Range("E" & i + 1)
            If InStr(1, Sh2.Range("E" & k), Chr(10)) > 1 Then Sh2.Range("E" & k) = Replace(Sh2.Range("E" & k), Chr(10), "")
            i = i + 1
        End If
Devam1:
        If Sh2.Range("D" & k) = "" Then
            Sh2.Range("D" & k) = Sh2.Range("C" & k)
            Sh2.Range("C" & k) = ""
        End If
        If Sh2.Range("H" & k) = "" Then
            Sh2.Range("H" & k) = Sh2.Range("G" & k)
            Sh2.Range("G" & k) = ""
        End If
SON:
    Next i
End Sub

 

[NADİR YILDIZ]

Sayın Nextlevel

harika olmuş tam istediğim gibi
Ne diyeyim Allah Razı olsun hakkınızı helal edin.

teşekkür eder iyi çalışmalar dilerim