26.05.2011

Worddateien - Tabelle nach Excel kopieren!

Frage: Aus vielen Worddokumenten soll eine Tabelle in Excel kopiert werden - jeweils auf ein neues Tabellenblatt. Es kann auch der gesamte Inhalt des Worddokumentes kopiert werden. Bitte den Pfad im Code anpassen.

Worddateien - Tabelle nach Excel kopieren...[ZIP, 90 KB]

Option Explicit
Dim blnTMP As Boolean
Public Sub Test()
Dim objDocument As Object
Dim strDatei As String
Dim strPfad As String
Dim objApp As Object
On Error GoTo Fin
' Pfad anpassen
strPfad = "C:\TMP\"
Set objApp = OffApp("Word")
' Word nicht sichtbar
'Set objApp = OffApp("Word", False)
If Not objApp Is Nothing Then
strDatei = Dir$(strPfad & "*.doc*", vbDirectory)
Do While strDatei <> ""
Set objDocument = objApp.Documents.Open _
(strPfad & strDatei)
' Die erste Tabelle wird kopiert
objDocument.Tables(1).Range.Copy
' Der gesamte Inhalt wird kopiert
'objDocument.Range.Copy
' und in ein neues Tabellenbatt eingefügt
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Paste
' Worddokument ohne speichern schlissen
objDocument.Close False
' Die nächste Datei nehmen
strDatei = Dir$()
Loop
Else
MsgBox "Applikation nicht installiert!"
End If
Fin:
If Not objApp Is Nothing Then
If blnTMP = True Then
objApp.Quit
blnTMP = False
End If
End If
Set objApp = Nothing
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
Optional blnVisible As Boolean = True) As Object
Dim objApp As Object
On Error Resume Next
Set objApp = GetObject(, strApp & ".Application")
Select Case Err.Number
Case 429
Err.Clear
Set objApp = CreateObject(strApp & ".Application")
blnTMP = True
If blnVisible = True Then
On Error Resume Next
objApp.Visible = True
Err.Clear
End If
End Select
On Error GoTo 0
Set OffApp = objApp
Set objApp = Nothing
End Function

12.05.2011

Protokoll - Datum - Tabellen!

Um zu sehen, ob ein Tabellenblatt aktuell ist sollen bei Änderungen in ein extra Tabellenblatt das Datum und die Uhrzeit protokolliert werden. Das Tabellenblatt heisst in meinem Beispiel "Protokoll" und ist ausgeblendet. Für jedes andere Tabellenblatt habe ich auf dem Sheet "Protokoll" einen Namen angelegt mit dem CodeNamen des jeweiligen Tabellenblattes. Protokolliert wird Tabellenblattname, CodeName des Tabellenblattes, Datum und Uhrzeit und der Username. Protokolliert wird auch, wenn alle Tabellenblätter markiert sind um Eingaben auf allen zu machen.

Protokoll - Datum - Tabellen...[ZIP, 60 KB]

' Folgender Code in "DieseArbeitsmappe":
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error GoTo Fin
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
If Sh.CodeName <> "Tabelle4" Then
With Tabelle4
.Unprotect
.Range(Sh.CodeName).Value = Sh.CodeName
.Range(Sh.CodeName).Offset(, 1).Value = Sh.Name
.Range(Sh.CodeName).Offset(, 2).Value = _
Format(Now, "DD.MM.YYYY HH:MM:SS")
.Range(Sh.CodeName).Offset(, 3).Value = Environ("UserName")
.Protect UserInterfaceOnly:=True
End With
End If
Fin:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub

Datei suchen - Pfad unbekannt - auslesen - kopieren!

Frage: Wie kann man eine Datei suchen, die irgendwo auf dem PC ist? Der Pfad ist nicht bekannt. Hier bietet sich die API-Funktion "SearchTreeForFile" an. Im folgenden Beispiel wird die Datei "Testdatei.xls" auf Laufwerk "C:\" gesucht. Wird sie gefunden können über die zwei folgenden Codes entweder zwei Zellen hineinkopiert bzw. zwei Zellen herausgelesen werden.

Datei suchen - Pfad unbekannt - auslesen - kopieren...[ZIP, 60 KB]

' Code für auslesen - kommt in Modul1
Option Explicit
Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
(ByVal RootPath As String, _
ByVal InputPathName As String, _
ByVal OutputPathBuffer As String) As Long
' Anpassungen eventuell vornehmen!!!
Const strFile As String = "Testdatei.xls"
Const strSheetQ As String = "Tabelle1"
Const strCell1 As String = "E1"
Const strCell2 As String = "E2"
Sub Test()
Dim strPathName As String * 255
Dim strName As String
Dim lngTMP As Long
On Error GoTo Fin
lngTMP = SearchTreeForFile("C:\", strFile, strPathName)
If lngTMP = 0 Then
Debug.Print "Datei nicht vorhanden"
Else
strPathName = Left$(strPathName, _
InStr(1, strPathName, vbNullChar) - 1)
strName = RTrim(strPathName)
With Tabelle1.Cells(1, 1)
.Formula = "='" & Mid(strName, 1, _
InStrRev(strName, "\")) & "[" & _
Mid(strName, InStrRev(strName, "\") + 1) & "]" & _
strSheetQ & "'!" & strCell1
.Value = .Value
End With
With Tabelle1.Cells(1, 2)
.Formula = "='" & Mid(strName, 1, _
InStrRev(strName, "\")) & "[" & _
Mid(strName, InStrRev(strName, "\") + 1) & "]" & _
strSheetQ & "'!" & strCell2
.Value = .Value
End With
End If
Fin:
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub

' Code für reinkopieren - kommt in Modul2
Option Explicit
Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
(ByVal RootPath As String, _
ByVal InputPathName As String, _
ByVal OutputPathBuffer As String) As Long
' Anpassungen eventuell vornehmen!!!
Const strFile As String = "Testdatei.xls"
Const strSheetQ As String = "Tabelle1"
Const strCell1 As String = "E1"
Const strCell2 As String = "E2"
Sub Test_1()
Dim strPathName As String * 255
Dim wkbBook As Workbook
Dim strName As String
Dim lngCalc As Long
Dim lngTMP As Long
On Error GoTo Fin
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
lngTMP = SearchTreeForFile("C:\", strFile, strPathName)
If lngTMP = 0 Then
Debug.Print "Datei nicht vorhanden"
Else
strPathName = Left$(strPathName, _
InStr(1, strPathName, vbNullChar) - 1)
strName = RTrim(strPathName)
Set wkbBook = Workbooks.Open(strName)
With wkbBook.Worksheets(strSheetQ)
.Cells(1, 1).Value = Tabelle1.Range(strCell1)
.Cells(1, 2).Value = Tabelle1.Range(strCell2)
End With
wkbBook.Close True
End If
Fin:
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With
Set wkbBook = Nothing
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub

Formeln auf einer UserForm in einer TextBox darstellen...

Formeln auf einer UserForm in einer TextBox anzeigen. Z. B. "Formula", "FormulaLocal"... und wie muss die Formel in VBA ...