harde returns verwijderen in Worddocument m.b.v. macro in Excel

[Egbert12345]

Beste forummers, ik ben voor het eerst op deze site en ik twijfel of ik mijn vraag hier moet plaatsen of in VBA. Voor oplettende lezers van andere sites, ik heb deze vraag ook op Office Forum geplaatst. Ik realiseer mij dat het niet gebruikelijk is om dezelfde vraag op diverse forums te plaatsen. Ik kreeg namelijk wel een antwoord, maar dat heeft mij niet verder geholpen en er wordt verder niet meer gereageerd.

Probleem is als volgt: Ik heb een programma in excel geschreven dat o.a. een worddocument opent en de inhoud kopieert naar excel. Dat worddocument met kolomme wordt gegenereerd vanuit een ander programma. In één kolom staan teksten met harde returns en het vervelend is dat bij het kopieren de tekst na elke harde return in een aparte cel wordt geplaatst. Nu wil ik voor het kopieren eerst alle harde returns verwijderen. Kan iemand mij helpen. Alvast bedankt voor de moeite.
m.vr.gr. Egbert (onderstaand de macro die ik gebruik)

PS Ik kreeg overigens het advies om de volgende code in te voegen, maar die werkt niet.
replace(activedocument.tables(1).range,vbcr," ")


Dim wordProgr As Word.Application
Dim excelProgr As Excel.Application
Dim excelDocument As Excel.Workbook
Dim wordDocument As Word.document
Dim locatieWordBestand As String
Set excelDocument = ActiveWorkbook
Set excelProgr = GetObject(, "Excel.Application")

DitPad = ActiveWorkbook.Path: zijpad = "\data mgmtinfo\": DirDatabestand = DitPad & zijpad: bestand = "agenda.xls"
Set wordProgr = CreateObject("Word.Application")

Application.ScreenUpdating = False: Application.DisplayAlerts = False
Workbooks.Add: Sheets("Blad1").Name = "agenda1": Sheets("Blad2").Name = "agenda2": Sheets("Blad3").Name = "agenda3": Sheets.Add: Sheets("Blad4").Name = "tmp"

locatieWordBestand = DirDatabestand & "Overzicht Beheeracties1.doc"
Set wordDocument = wordProgr.Documents.Open(locatieWordBestand)
With wordProgr: .Visible = True:
.Selection.WholeStory:
.Selection.Copy:
End With

With excelProgr: .Sheets("agenda1").Select: End With
Range("A1").Select: ActiveSheet.Paste: Range("A1").Select:

 

[wiki]

Of een macro achteraf

Sub test()
Dim c As Long, r As Long
Dim x As String, y As String
Dim LastRowInA As Long
LastRowInA = Range("a65536").End(xlUp).Row

For r = 1 To LastRowInA 'rijen

y = x & ActiveSheet.Cells(r, 1) & " "
x = y

Next r
ActiveSheet.Cells.ClearContents
Range("a1").Value = x

End Sub

gr wim

 

[Egbert12345]

Hallo Wim, ik had nog iets moeten uitleggen. Ik geef een voorbeeld.
In Word staat bijvoorbeeld in kolom 1 de naam van de klant en in kolom 2 één toelichting met een aantal harde returns.

Als ik deze twee kolommen kopieer naar excel dan is het resultaat:
cel A1 klantnaam
cel B1 toelichting tot eerste return
cel B2 toelichting vanaf eerste tot tweede return etc
Het moet zo zijn dat ik in cel B1 de volledige toelichting heb.

Ik dacht door voor het kopieren eerste alle harde returns te verwijderen in het worddocument. Ben ik zo een beetje duidelijk?

m.vr.gr. Egbert

 

[wiki]

Het is lastig zonder voorbeeld, maar is de volgende beredenering correct.
Data in kolom a bevat geen harde returns
De volgende klant in kolom a staat in a3
maw de cellen kolom b moeten samengevoegd worden tot er weer een warde in kolom a staat

Als de opbouw te herleiden is kun veel met VBA eventueel met tussenstapjes

Post anders een voorbeeldje. Doe je import en pas klantnamen ed even aan.

gr wim

 

[sylvester-ponte]

probeer dit eens:

Sub test2()
    Dim C As Range: Set C = Range("B2")
    Range("B" & Range("b65536").End(xlUp).Row + 1) = "Eindlsdjkjasld"
    Do
    If C = "Eindlsdjkjasld" Then C.ClearContents: Exit Sub
    If C.Offset(0, -1) = "" Then
        C.Offset(-1, 0) = C.Offset(-1, 0) & C
        Set C = C.Offset(1, 0)
        Rows(C.Row - 1).Delete Shift:=xlUp
    Else
        Set C = C.Offset(1, 0)
    End If
   Loop
End Sub

groet sylvester

 

[cow18]

wat zou er kunnen mis zijn aan de voorgestelde code ??
misschien zijn het geen vbCr maar een andere nr, dus eigenlijk zou je best eens dat word-bestandje hier neerzetten, anders blijft het gokken.
Ik heb even wat gestoeid met die macro en ik krijg hem toch aan de praat, mits wat aanpassingen (sommige enkel om voor mijn voorbeeldje)

Sub x()
  Dim wordProgr As Word.Application
  Dim excelProgr As Excel.Application
  Dim excelDocument As Excel.Workbook
  Dim wordDocument As Word.document
  Dim locatieWordBestand As String
  Set excelDocument = ActiveWorkbook
  Set excelProgr = GetObject(, "Excel.Application")
  Dim DitPad As String, Zijpad As String, Dirdatabestand As String, bestand As String, locatiebestand As String

  DitPad = ActiveWorkbook.Path
  Zijpad = "\"
  Dirdatabestand = DitPad & Zijpad
  bestand = "agenda.xls"
  Set wordProgr = CreateObject("Word.Application")

  Application.ScreenUpdating = False: Application.DisplayAlerts = False
  Workbooks.Add: Sheets("Blad1").Name = "agenda1"          ': Sheets("Blad2").Name = "agenda2": Sheets("Blad3").Name = "agenda3": Sheets.Add: Sheets("Blad4").Name = "tmp"

  locatieWordBestand = DitPad & "\" & "doc1.docx"
  Set wordDocument = wordProgr.Documents.Open(locatieWordBestand)
  With wordProgr
    .Visible = True
    .Selection.Find.ClearFormatting
    .Selection.Find.Replacement.ClearFormatting
    With .Selection.Find
      .Text = vbCr
      .Replacement.Text = " "
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
    End With
    .Selection.Find.Execute Replace:=wdReplaceAll
    '    replace(activedocument.tables(1).range,vbcr," ")
    .Selection.WholeStory
    .Selection.Copy
  End With

  With excelProgr: .Sheets("agenda1").Select: End With
  Range("A1").Select: ActiveSheet.Paste: Range("A1").Select:
End Sub

 

[sylvester-ponte]

hier gebeurt wat Wiki zegt:maw de cellen kolom b moeten samengevoegd worden tot er weer een warde in kolom a staat

in vorige versie
moet nog een spatie toevoegen:

Sub test2()
    Dim C As Range: Set C = Range("B2")
    Range("B" & Range("b65536").End(xlUp).Row + 1) = "Eindlsdjkjasld"
    Do
    If C = "Eindlsdjkjasld" Then C.ClearContents: Exit Sub
    If C.Offset(0, -1) = "" Then
        C.Offset(-1, 0) = C.Offset(-1, 0) &" "& C
        Set C = C.Offset(1, 0)
        Rows(C.Row - 1).Delete Shift:=xlUp
    Else
        Set C = C.Offset(1, 0)
    End If
   Loop
End Sub

als het wordbestand in exel is ingevoerd moet dit macrotje werken.
groet sylvester

 

[Egbert12345]

Beste forummers, excuses voor de late reactie. Bedankt voor alle aangeboden oplossingen.

In de tussentijd heb ik een nogal omslachtige noodoplossing gevonden die werkt. Ik ga zeker jullie suggesties doornemen.

m.vr.gr. Egbert

 

[wiki]

Had dan ook een voorbeeldbestandje gepost dat had je veel tijd kunnen besparen.


gr wim