ich hoffe du (oder auch gern jemand anderes) kannst mir nochmal helfen.
Dein Code von gestern funktionier super, aber.....
In der Praxis ist vollgendes Problem aufgetaucht:
Ich habe viele Worddateien, in jeder Datei sind jeweils 2 Tabellen (Tables).
In dem bisherigen Code habe ich den Inhalt des gesamten Dokumentes kopiert und als Text in Excel eingefügt. Dabei kommen unterschiedliche Ergebnisse zu stande!?!?!?!
Ich gehe davon aus, dass es etwas mit der Seiteneinrichtung zu tun hat. Die Dateien haben einen unterschiedlichen Seiteneinzug.
Nun habe ich im Archiv noch einen Beitrag gefunden, der wohl die einzelnen Tabellen anwählt.
Aber ich schaffe es nicht deinen Code mit dem anderen Code zu kombinieren. :O(
Hier nochmal dein Code mit meinen kleinen Anpassungen im Teil "
Private Sub CommandButton1_Click()
' Modul: Modul1 Typ: Allgemeines Modul
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As _
String, ByVal lpWindowName As String) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Public Sub loeschen_Zwischenablage()
OpenClipboard FindWindow("xlMain", vbNullString)
EmptyClipboard
CloseClipboard
End Sub
Private Sub CommandButton1_Click()
Dim I, J, A As Integer
Dim AppWD As Object
Dim objFiles() As Object
Dim lngR As Long, lngRes As Long, lngIndex As Long
Dim strDirectory As String
On Error GoTo ErrExit
GMS
strDirectory = fncBrowseForFolder("C:\")
If strDirectory "" Then
lngRes = FileSearchINFO(objFiles, strDirectory, "*.doc", True)
If lngRes > 0 Then
lngR = ThisWorkbook.Sheets("Tabelle2").Cells(Rows.Count, 1).End(xlUp).Row
Set AppWD = CreateObject("Word.Application") 'Word als Object starten
With AppWD
.DisplayAlerts = False
.Visible = False
For lngIndex = 0 To lngRes - 1
.documents.Open CStr(objFiles(lngIndex))
.Selection.wholestory
.Selection.Copy
ThisWorkbook.Sheets("Tabelle1").Cells(1, 1).Select
ThisWorkbook.Sheets("Tabelle1").PasteSpecial _
Format:="Text", Link:=False, DisplayAsIcon:=False
loeschen_Zwischenablage
.documents.Close
A = 1
For J = 1 To 28
For I = 1 To 2
Sheets(2).Cells(1 + lngR, A) = Sheets(1).Cells(J, I)
A = A + 1
Next I
Next J
lngR = lngR + 1
Next
.DisplayAlerts = True
.Quit
End With
End If
End If
ErrExit:
With Err
If .Number 0 Then MsgBox "Fehler " & .Number & vbLf & vbLf & _
.Description & vbLf & vbLf & "In Prozedur (CommandButton1_Click) in Modul Modul1", _
vbExclamation, "Fehler in Modul1 / CommandButton1_Click"
End With
GMS True
'If Not AppWD Is Nothing Then AppWD.Quit
Set AppWD = Nothing
Range("A:B").ClearContents
Cells(1, 3).Select
End Sub
Public Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Not Modus Then lngCalc = .Calculation
If Modus And lngCalc = 0 Then lngCalc = -4105
.Calculation = IIf(Modus, lngCalc, -4135)
.Cursor = IIf(Modus, -4143, 2)
End With
End Sub
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
Dim objFlderItem As Object, objShell As Object, objFlder As Object
Set objShell = CreateObject("Shell.Application")
Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)
If objFlder Is Nothing Then GoTo ErrExit
Set objFlderItem = objFlder.Self
fncBrowseForFolder = objFlderItem.Path
ErrExit:
Set objShell = Nothing
Set objFlder = Nothing
Set objFlderItem = Nothing
End Function
Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional _
ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long
'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*. _
*" findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard= _
False)
Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
Dim intC As Integer, varFiles As Variant
Set fobjFSO = CreateObject("Scripting.FileSystemObject")
Set ffsoFolder = fobjFSO.GetFolder(InitialPath)
On Error GoTo ErrExit
If InStr(1, FileName, ";") > 0 Then
varFiles = Split(FileName, ";")
Else
ReDim varFiles(0)
varFiles(0) = FileName
End If
For Each ffsoFile In ffsoFolder.Files
If Not ffsoFile Is Nothing Then
For intC = 0 To UBound(varFiles)
If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
If IsArray(Files) Then
ReDim Preserve Files(UBound(Files) + 1)
Else
ReDim Files(0)
End If
Set Files(UBound(Files)) = ffsoFile
Exit For
End If
Next
End If
Next
If SubFolders Then
For Each ffsoSubFolder In ffsoFolder.SubFolders
FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
Next
End If
If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
ErrExit:
Set fobjFSO = Nothing
Set ffsoFolder = Nothing
End Function
Und hier der Code aus dem Archiv der wohl die 1. Tabelle nur kopiert:
Sub WordNachExcel()
Dim objWordApp As Word.Application
Dim objWordDok As Word.Document
Dim Pfad As String
Dim a As Long
Dim strText As Variant
On Error GoTo Fehler:
Application.ScreenUpdating = False
Pfad = _
IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\")
Set objWordApp = New Word.Application
objWordApp.Visible = False
Set objWordDok = objWordApp.Documents.Open(Pfad & "Dok1.doc")
With objWordDok.Tables(1).Range
For a = 1 To .Cells.Count
strText = .Cells(a)
strText = Replace(Replace(strText, Chr(7), ""), Chr(13), Chr(10))
If Right$(strText, 1) = Chr(10) Then strText = Left$(strText, Len(strText) - 1)
Cells(.Cells(a).RowIndex, .Cells(a).ColumnIndex) = strText
Next a
End With
Fehler:
On Error Resume Next
objWordDok.Close False
Set objWordApp = Nothing
Set objWordDok = Nothing
Application.ScreenUpdating = True
If Err.Number 0 Then MsgBox Err.Description, vbCritical, "Fehler beim lesen!"
End Sub
Ich bitte nochmals um Hiiillllffffeeeee!!!
LG
Dirk R.