Kennt jemand einen Trick?
Vielen Dank für eure Hilfe und Gruss
Doris
Sub WordCheckBoxes()
Dim WordApp As New Word.Application 'Verweis auf Microsoft Word Object Library
Dim WordDoc As Word.Document
Dim x As Long
Set WordDoc = WordApp.Documents.Open("U:\Checkbox.doc")
For x = 1 To WordDoc.InlineShapes.Count
Cells(x, 1) = WordDoc.InlineShapes(x).OLEFormat.ClassType
Cells(x, 2) = WordDoc.InlineShapes(x).OLEFormat.Object.Caption
Cells(x, 3) = WordDoc.InlineShapes(x).OLEFormat.Object.Name
Cells(x, 4) = WordDoc.InlineShapes(x).OLEFormat.Object.Value
Next x
WordDoc.Close
WordApp.Quit
End Sub
Klingen tut das irgendwie gar nicht schlecht. Jetzt müsste ich bloss noch wissen, wie ich den Makro den nun genau zum funktionieren bringe (was muss ich in Word, was in Excel machen?).
Kannst du mir evtl. den Workflow darlegen? Ich habe mit Makros bis jetzt leider (wie du siehst)noch nicht viel am Hut, sorry.
Gruss
Doris
Du speicherst alle Word-Dateien in ein Verzeichnis. Als Dateiname wählst Du den Namen des Befragten. Danach erstellst Du aus dem Makro auf https://www.herber.de/mailing/060599h.htm und meinem Makro ein neues Makro, welches Dir aus allen Dateien eines Verzeichnisses die Daten ausliest und ins Excel einträgt.
Hier ein auf die Schnelle zusammengebasteltes Beispiel:
Sub Einlesen()
Dim Pfad$, FName$, FCount%, FileArray()
Pfad = InputBox("Pfad:", , "C:\Fragebogen")
If Right(Pfad, 1) = "\" Then Pfad = Left(Pfad, Len(Pfad) - 1)
If Pfad = "" Then Exit Sub
On Error GoTo ErrorHandler
ChDrive Left(Pfad, 1)
ChDir Pfad
On Error GoTo 0
FName = Dir("*.*")
Do While FName <> ""
FCount = FCount + 1
ReDim Preserve FileArray(1 To FCount)
FileArray(FCount) = FName
FName = Dir()
Loop
Dim WordApp As New Word.Application
Dim WordDoc As Word.Document
Dim x As Long, FileNr As Long
For FileNr = 1 To FCount
Set WordDoc = WordApp.Documents.Open(Pfad & "\" & FileArray(FileNr))
Cells(FileNr, 1) = WordDoc.Name
For x = 1 To WordDoc.InlineShapes.Count
Cells(FileNr, x + 1) = WordDoc.InlineShapes(x).OLEFormat.Object.Value
Next x
WordDoc.Close
Next FileNr
WordApp.Quit
End
ErrorHandler:
MsgBox "Pfad wurde nicht gefunden!"
End Sub