19.07.2011

Tabellenblatt einfügen abfangen Vorlage kopieren

Wie kann (M)man(n) das einfügen von Tabellenblättern Applikationsweit abfangen um eine eigene Vorlage einzufügen? Das ganze soll als Addin laufen. Da gibt es ja das Ereignis "Private Sub Workbook_NewSheet(ByVal Sh As Object)" in "DieseArbeitsmappe". Das greifen wir uns und packen alles in ein Addin. Um das zu knacken sollte (M)man(n) in der Hilfe nach "WorkbookNewSheet" schauen.

Tabellenblatt einfügen abfangen Vorlage kopieren...[ZIP, 70 KB]

' Code in "DieseArbeitsmappe"
Option Explicit
Dim AppObject As New clsDatei
Private Sub Workbook_Open()
Set AppObject.AppLiCa = Application
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set AppObject.AppLiCa = Nothing
End Sub

' Code in ein Klassenmodul mit Namen "clsDatei"
Option Explicit
Public WithEvents AppLiCa As Application
Private Sub AppLiCa_WorkBookNewSheet(ByVal Wb As Workbook, _
ByVal Sh As Object)
On Error GoTo Fin
With AppLiCa
.ScreenUpdating = False
.DisplayAlerts = False
End With
With Wb
.Worksheets(.Worksheets.Count).Delete
ThisWorkbook.Worksheets("Vorlage").Copy _
After:=.Worksheets(Worksheets.Count)
.Worksheets(Worksheets.Count).Name = "New" & .Worksheets.Count
End With
Fin:
With AppLiCa
.ScreenUpdating = True
.DisplayAlerts = True
End With
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub

30.06.2011

Geschlossene Dateien - ADO - Tabellenblatt!

Frage: Der Tabellenblattname kann nicht genau festgelegt werden. Es können zwei verschiedene Namen sein. Dies geht aber nicht, wenn quasi geschlossene Dateien per Formel ausgelesen werden. Hier wird per ADO geprüft, welches Tabellenblatt in der Datei ist.

Geschlossene Dateien - ADO - Tabellenblatt...[ZIP, 140 KB]

Option Explicit
Const strSheetZ As String = "Tabelle1" ' Die Tabelle in dieser Datei
Const strCellQ1 As String = "L8" ' Die Zelle wird ausgelesen
Const strCellQ2 As String = "L6" ' Die Zelle wird ausgelesen
Public Sub Files_Read()
Dim stCalc As Integer
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
stCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
' Wenn der Inhalt vorher gelöscht werden soll
' ThisWorkbook.Worksheets(strSheetZ).Columns("A:C").ClearContents
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Datei im gleichen Ordner wie Auswertungsdateien
strDir = ThisWorkbook.Path
Set objDir = objFSO.GetFolder(strDir)
'dirInfo objDir, "*.xls*", True ' Mit Unterordner
dirInfo objDir, "*.xls*"
Fin:
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = stCalc
.DisplayAlerts = True
End With
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
Set objDir = Nothing
Set objFSO = Nothing
End Sub
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
Optional ByVal blnTMP As Boolean = False)
Dim objWorkbook As Workbook
Dim strFormula As String
Dim lngLastRow As Long
Dim strSheet As String
Dim varTMP As Variant
For Each varTMP In objCurrentDir.Files
If varTMP.Name Like strName And varTMP.Name <> _
ThisWorkbook.Name Then
If Left(varTMP.Name, 1) <> "~" Then
strSheet = ADOSheet(varTMP.Path)
With ThisWorkbook.Worksheets(strSheetZ)
lngLastRow = IIf(Len(.Cells(.Rows.Count, 2)), _
.Rows.Count, .Cells(.Rows.Count, 2).End(xlUp).Row) + 1
With .Cells(lngLastRow, 2)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheet & "'!" & strCellQ1
.Value = .Value
.Offset(0, -1).Value = varTMP.Name
End With
With .Cells(lngLastRow, 3)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheet & "'!" & strCellQ2
.Value = .Value
End With
End With
End If
End If
Next varTMP
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, blnTMP
Next varTMP
End If
Set objWorkbook = Nothing
End Sub
Private Function ADOSheet(ByVal strFileName As String) As String
Dim strSheetQ1 As String
Dim strSheetQ As String
Dim objConn As Object
Dim objCat As Object
Dim objTab As Object
On Error GoTo Fin
strSheetQ1 = "Project_Data"
strSheetQ = "Projektdaten"
Set objConn = CreateObject("ADODB.Connection")
With objConn
.CursorLocation = 3 ' = adUseClient
If Val(Application.Version) >= 12 Then
.Provider = "Microsoft.ACE.OLEDB.12.0;" & _
"Extended Properties=""Excel 12.0;HDR=YES"";" & _
"Data Source=" & strFileName & ";"
Else
.Provider = "Microsoft.Jet.OLEDB.4.0;" & _
"Extended Properties=Excel 8.0;" & _
"Data Source=" & strFileName & ";"
End If
.Open
End With
Set objCat = CreateObject("ADOX.Catalog")
Set objCat.ActiveConnection = objConn
For Each objTab In objCat.Tables
If objTab.Name Like "Project_*" Then
ADOSheet = strSheetQ1: Exit Function
ElseIf objTab.Name Like "Projektda*" Then
ADOSheet = strSheetQ: Exit Function
End If
Next objTab
Fin:
Set objCat = Nothing
If Not objConn Is Nothing Then
If objConn.State = 1 Then objConn.Close
End If
Set objConn = Nothing
End Function

28.06.2011

Tabellenblätter Passwort einblenden/ausblenden!

Über eine Startseite sollen alle Tabellenblätter nur mit Passwort eingeblendet werden können. Diese sind in der Regel ausgeblendet "xlSheetVeryHidden". Auswahl über eine UserForm. Wird auf die Startseite zurückgegangen wird das entsprechende Tabellenblatt wieder ausgeblendet.

Tabellenblätter Passwort einblenden/ausblenden...[ZIP, 60 KB]

' Code in ein Modul
Option Explicit
Option Private Module
Sub Alle_Ausblenden()
Dim wksSheet As Worksheet
For Each wksSheet In ThisWorkbook.Worksheets
If wksSheet.Name <> "Start" Then
wksSheet.Visible = xlSheetVeryHidden
End If
Next wksSheet
End Sub
Sub UF_Show()
UserForm1.Show
End Sub

' Code in UserForm1
Option Explicit
Private Sub UserForm_Activate()
Dim wksSheet As Worksheet
For Each wksSheet In ThisWorkbook.Worksheets
If wksSheet.Name <> "Start" And wksSheet.Name <> "Pass" Then
ComboBox1.AddItem (wksSheet.Name)
End If
Next wksSheet
ComboBox1.ListIndex = 0
With TextBox1
.Text = ""
.PasswordChar = "*"
.MaxLength = 5
.SetFocus
End With
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub CommandButton1_Click()
If Trim(TextBox1.Text) = "" Then
MsgBox "Kennwort fehlt", vbOKOnly, "Nachricht"
TextBox1.SetFocus
ElseIf TextBox1.Text <> ThisWorkbook.Worksheets("Pass") _
.Range(ComboBox1.Value) Then
MsgBox "Kennwort falsch, wiederholen / abbrechen", _
vbOKOnly, "Nachricht"
TextBox1.Text = ""
TextBox1.SetFocus
Else
ThisWorkbook.Worksheets _
(ComboBox1.Value).Visible = xlSheetVisible
Application.Goto ThisWorkbook.Worksheets _
(ComboBox1.Value).Range("A1"), True
Unload Me
End If
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then Cancel = True
End Sub

' Code in diese Arbeitsmappe
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call Alle_Ausblenden
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh.Name = "Start" Then Call Alle_Ausblenden
End Sub

16.06.2011

Formeln - Werte - Speichern ohne Makros!

Achtung - funktioniert nur in Excel 2007 bzw. 2010. Wenn man in Excel 2007/2010 eine XLSM-Datei mit Makros OHNE Makros speichern möchte, kann man diese Datei einfach als XLSX speichern und die Makros sind alle weg. Ein Button im Tabellenblatt (aus Formularsteuerelemente) löscht sich beim Klick durch "Application.Caller" von selber. Formeln werden durch die Werte ersetzt. Noch andere vorhandene Tabellenblätter werden gelöscht und die Datei dann mit "SaveAs" als XLSX gespeichert. Die Ursprungsdatei bleibt bestehen.

Formeln - Werte - Speichern ohne Makros...[ZIP, 50 KB]

Option Explicit
Const strFileName As String = "Dateiname"
Private Sub Test()
Dim wksSheet As Worksheet
Dim varPath As Variant
On Error GoTo Fin
Application.DisplayAlerts = False
varPath = Application.GetSaveAsFilename( _
InitialFileName:=ThisWorkbook.Path & "\" & strFileName, _
FileFilter:="Excel(*.xlsx), *.xlsx", _
Title:="Speichern ohne Makros")
If Not varPath = False Then
For Each wksSheet In ThisWorkbook.Worksheets
If wksSheet.Name <> ActiveSheet.Name Then
wksSheet.Delete
End If
Next wksSheet
With ActiveSheet
.Shapes(Application.Caller).Delete
.UsedRange.Value = .UsedRange.Value
End With
With ThisWorkbook
.SaveAs varPath, 51
.Close False
End With
End If
Fin:
Application.DisplayAlerts = True
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub

15.06.2011

Ausgeblendete Tabellenblätter Inhalt anzeigen!

Es soll nur ein Tabellenblatt sichtbar sein. Alle restlichen Sheets sind per "xlSheetVeryHidden" ausgeblendet. In einer ComboBox auf dem ersten Tabellenblatt können die Tabellenblätter ausgewählt und der Inhalt angezeigt werden.

Ausgeblendete Tabellenblätter Inhalt anzeigen...[ZIP, 70 KB]

Option Explicit
Private Sub Workbook_Open()
Dim intTMP As Integer
On Error GoTo Fin
With Tabelle1
.ComboBox1.Clear
.ComboBox1.AddItem ("Auswahl...")
For intTMP = 1 To ThisWorkbook.Worksheets.Count
If ThisWorkbook.Worksheets(intTMP).Index > 1 Then
.ComboBox1.AddItem _
(ThisWorkbook.Worksheets(intTMP).Name)
End If
Next intTMP
.ComboBox1.ListIndex = 0
End With
Fin:
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim wksSheet As Worksheet
For Each wksSheet In ThisWorkbook.Worksheets
If wksSheet.Index > 1 Then _
wksSheet.Visible = xlSheetVeryHidden
Next wksSheet
End Sub

Daten Spalte B jeweils in neue Dateien aufteilen!

Frage aus Office-Loesung: Werte aus Spalte B die jeweils ein- oder auch mehrmals unsortiert vorliegen, sollen in neue Dateien abgespeichert werden. Im folgenden Beispiel von Spalte A bis Spalte D. Gelöst über temporäre Tabellenblätter und den Spezialfilter. Eventuell vorhandene Dateien mit gleichem Namen werden ohne Nachfrage überschrieben.

Daten Spalte B jeweils in neue Dateien aufteilen...[ZIP, 50 KB]

Option Explicit
Public Sub Aufteilen()
Dim wksKriterienSheet As Worksheet
Dim wksQuellSheet As Worksheet
Dim rngKriterium As Range
Dim wksNew As Worksheet
Dim wkbBook As Workbook
Dim lngLastRow As Long
On Error GoTo Fin
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
' Tabellenblatt mit Daten - Name ANPASSEN
Set wksQuellSheet = Worksheets("Gesamt")
Set wksKriterienSheet = Worksheets.Add
wksKriterienSheet.Move After:= _
ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
lngLastRow = wksQuellSheet.Range("B" & Rows.Count).End(xlUp).Row
wksQuellSheet.Range("B1:B" & lngLastRow).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=wksKriterienSheet.Range("A1"), Unique:=True
Set rngKriterium = wksKriterienSheet.Range("A2")
While rngKriterium.Value <> ""
Set wksNew = Worksheets.Add
wksQuellSheet.Range("A1:D" & lngLastRow).AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=rngKriterium.Offset(-1).Resize(2), _
CopyToRange:=wksNew.Range("A1"), Unique:=True
wksNew.Name = rngKriterium.Text
rngKriterium.EntireRow.Delete
wksNew.Copy
Set wkbBook = ActiveWorkbook
If Val(Application.Version) < 12 Then
wkbBook.SaveAs ThisWorkbook.Path & _
"\" & wksNew.Name & ".xls"
Else
wkbBook.SaveAs ThisWorkbook.Path & _
"\" & wksNew.Name, 56
End If
wkbBook.Close SaveChanges:=False
Set wkbBook = Nothing
wksNew.Delete
Set wksNew = Nothing
Set rngKriterium = Nothing
Set rngKriterium = wksKriterienSheet.Range("A2")
Wend
wksKriterienSheet.Delete
Set wksKriterienSheet = Nothing
Fin:
If Not wksNew Is Nothing Then _
wksNew.Delete
If Not wksKriterienSheet Is Nothing Then _
wksKriterienSheet.Delete
With Application
.Goto wksQuellSheet.Range("A1"), True
.ScreenUpdating = True
.DisplayAlerts = True
End With
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
Set wkbBook = Nothing
Set wksKriterienSheet = Nothing
Set wksQuellSheet = Nothing
Set rngKriterium = Nothing
Set wksNew = Nothing
End Sub

07.06.2011

Heutiges Datum - Spalte A - Finden - Markieren!

In Spalte A stehen die Tage des jeweiligen Jahres in der Form 01.01.2011 bis 31.12.2011. Es soll nun zum aktuellen Datum gesprungen werden. Dazu nutze ich die "FollowHyperlink-Prozedur" des Worksheetobjektes. Der Code gehört in den Codebereich des entsprechenden Tabellenblattes.

Heutiges Datum - Spalte A - Finden - Markieren...[ZIP, 50 KB]

Option Explicit
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Application.Goto Range("A:A").Find _
(Date, LookIn:=xlValues, LookAt:=xlPart), True
End Sub

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

Word - Kontrollkästchen (Formularsteuerelement) auslesen...

Aus allen Worddateien sollen die Kontrollkästchen (Formularsteuerelement) ausgelesen werden - Haken gesetzt oder nicht. Auch ein Textfeld (F...