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

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

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