Posts

Es werden Posts vom 2011 angezeigt.

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 AsNew clsDatei
PrivateSub Workbook_Open()
Set AppObject.AppLiCa = Application
EndSub
PrivateSub Workbook_BeforeClose(Cancel AsBoolean)
Set AppObject.AppLiCa =Nothing
EndSub

' Code in ein Klassenmodul mit Namen "clsDatei"
Option Explicit
Public WithEvents AppLiCa As Application
PrivateSub AppLiCa_WorkBookNewSheet(ByVal Wb As Workbook,_
ByVal Sh AsObject)
OnErrorGoTo Fin
With AppLiCa
.ScreenUpdating =False
.DisplayAlerts =False
EndWith
With Wb
.Worksheets…

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 AsString="Tabelle1"' Die Tabelle in dieser Datei
Const strCellQ1 AsString="L8"' Die Zelle wird ausgelesen
Const strCellQ2 AsString="L6"' Die Zelle wird ausgelesen
PublicSub Files_Read()
Dim stCalc AsInteger
Dim strDir AsString
Dim objFSO AsObject
Dim objDir AsObject
OnErrorGoTo Fin
With Application
.ScreenUpdating =False
.AskToUpdateLinks =False
.EnableEvents =False
stCalc =.Calculation
.Calculation = xlCalculationManual
.DisplayAlerts =False
EndWith
' Wenn der Inhalt vorher gelöscht werden soll
' ThisWorkbook.Worksheets(strSheetZ).Columns("A:C").ClearContents
Set objFSO =CreateObject("Scriptin…

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
OptionPrivateModule
Sub Alle_Ausblenden()
Dim wksSheet As Worksheet
ForEach wksSheet In ThisWorkbook.Worksheets
If wksSheet.Name<>"Start"Then
wksSheet.Visible = xlSheetVeryHidden
EndIf
Next wksSheet
EndSub
Sub UF_Show()
UserForm1.Show
EndSub

' Code in UserForm1
Option Explicit
PrivateSub UserForm_Activate()
Dim wksSheet As Worksheet
ForEach wksSheet In ThisWorkbook.Worksheets
If wksSheet.Name<>"Start" And wksSheet.Name<>"Pass"Then
ComboBox1.AddItem (wksSheet.Name)
EndIf
Next wksSheet
ComboBox1.ListIndex =0
With TextBox1
.Text =""
.Passwor…

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 AsString="Dateiname"
PrivateSub Test()
Dim wksSheet As Worksheet
Dim varPath AsVariant
OnErrorGoTo Fin
Application.DisplayAlerts =False
varPath = Application.GetSaveAsFilename(_
InitialFileName:=ThisWorkbook.Path &"\"& strFileName,_
FileFilter:="Excel(*.xlsx), *.xlsx",_
Title:="Speichern ohne Makros")
I…

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
PrivateSub Workbook_Open()
Dim intTMP AsInteger
OnErrorGoTo Fin
With Tabelle1
.ComboBox1.Clear
.ComboBox1.AddItem ("Auswahl...")
For intTMP =1To ThisWorkbook.Worksheets.Count
If ThisWorkbook.Worksheets(intTMP).Index >1Then
.ComboBox1.AddItem _
(ThisWorkbook.Worksheets(intTMP).Name)
EndIf
Next intTMP
.ComboBox1.ListIndex =0
EndWith
Fin:
IfErr.Number <>0ThenMsgBox"Fehler: "&_
Err.Number &" "&Err.Description
EndSub
PrivateSub Workbook_BeforeClose(Cancel AsBoolean)
Dim wksSheet As Worksheet
ForEach wksSheet In ThisWorkbook.Worksheets
If wksSheet.Index >1Then_
wksSheet.Visible = xlSheetVeryHidden
Next wksSheet
EndSub

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
PublicSub Aufteilen()
Dim wksKriterienSheet As Worksheet
Dim wksQuellSheet As Worksheet
Dim rngKriterium As Range
Dim wksNew As Worksheet
Dim wkbBook As Workbook
Dim lngLastRow AsLong
OnErrorGoTo Fin
With Application
.ScreenUpdating =False
.DisplayAlerts =False
EndWith
' 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
wksQue…

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
PrivateSub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Application.Goto Range("A:A").Find _
(Date, LookIn:=xlValues, LookAt:=xlPart),True
EndSub

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 AsBoolean
PublicSub Test()
Dim objDocument AsObject
Dim strDatei AsString
Dim strPfad AsString
Dim objApp AsObject
OnErrorGoTo Fin
' Pfad anpassen
strPfad ="C:\TMP\"
Set objApp = OffApp("Word")
' Word nicht sichtbar
'Set objApp = OffApp("Word", False)
IfNot objApp Is NothingThen
strDatei =Dir$(strPfad &"*.doc*", vbDirectory)
DoWhile 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:…

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
PrivateSub Workbook_SheetChange(ByVal Sh AsObject,ByVal Target As Range)
OnErrorGoTo Fin
With Application
.ScreenUpdating =False
.EnableEvents =False
EndWith
If Sh.CodeName <>"Tabelle4"Then
With Tabelle4
.Unprotect
.Range(Sh.CodeName).Value = Sh.CodeName
.Range(Sh.CodeName).Offset(,1).Value = Sh.Name
.…

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 AsString,_
ByVal InputPathName AsString,_
ByVal OutputPathBuffer AsString)AsLong
' Anpassungen eventuell vornehmen!!!
Const strFile AsString="Testdatei.xls"
Const strSheetQ AsString="Tabelle1"
Const strCell1 AsString="E1"
Const strCell2 AsString="E2"
Sub Test()
Dim strPathName AsString*255
Dim strName AsString
Dim lngTMP AsLong
OnErrorGoTo Fin
lngTMP = Search…