31.03.2011

Geschlossene Dateien - Datum - Bedingung!

Eine unerschöpfliche Quelle - geschlossene Dateien auslesen. Hier eine Frage aus Office-Loesung. Aus Tabellenblatt 1 sollen 4 Werte ausgelesen werden, aus Tabellenblatt 2 Werte aus Spalten, aber nur jede zweite. Zusätzlich ist auf Tabellenblatt 2 in Zelle E3 ein Datum. Es darf erst mit dem Auslesen ab dem Datum begonnen werden. Im ersten Code wird alles ausgelesen, im zweiten Code ist die Datumsbedingung mit eingearbeitet. Bitte erst die ReadMe.txt im Download lesen!

Geschlossene Dateien - Datum - Bedingung mit Beispieldateien...[ZIP, 160 KB]

' Code gehört in Modul1

Option Explicit
' Die Tabelle wird ausgelesen
Const strSheetQ1 As String = "Tabelle1"
' Die Tabelle wird ausgelesen
Const strSheetQ2 As String = "Tabelle2"
' Die Tabelle in dieser Datei
Const strSheetZ As String = "Gesamt"
' Die Zelle wird ausgelesen
Const strCellQ1 As String = "C"
' Die Zeile in Tabelle2 wird ausgelesen
Const lngRow As Long = 10
Public Sub Files_Read()
Dim strListing As String
Dim intCalc 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
intCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Mit Ordnerauswahl - dann die entsprechenden unteren
' Codezeilen auskommentieren
' If funcDirectory(strDir) <> "" Then
' Set objDir = objFSO.GetFolder(strDir)
' ThisWorkbook.Worksheets(strSheetZ).Rows _
' ("2:" & Rows.Count).ClearContents
' 'dirInfo objDir, "*.xls*", True ' Mit Unterordner
' dirInfo objDir, "*.xls*"
' End If
' Datei im gleichen Ordner wie Auswertungsdateien
'strDir = ThisWorkbook.Path
' Datei im fest vorgegebenen Ordner
strDir = "C:\Temp\Test1"
Set objDir = objFSO.GetFolder(strDir)
ThisWorkbook.Worksheets(strSheetZ).Rows _
("2:" & Rows.Count).ClearContents
'dirInfo objDir, "*.xls*", True ' Mit Unterordner
dirInfo objDir, "*.xls*"
Fin:
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = intCalc
.DisplayAlerts = True
End With
Set objDir = Nothing
Set objFSO = Nothing
End Sub
Private 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 intCount As Integer
Dim strSpalte As String
Dim lngLastRow As Long
Dim intTMP As Integer
Dim varTMP As Variant
For Each varTMP In objCurrentDir.Files
If varTMP.Name Like strName And _
varTMP.Name <> ThisWorkbook.Name And _
Left(varTMP.Name, 1) <> "~" Then
With ThisWorkbook.Worksheets(strSheetZ)
lngLastRow = IIf(Len(.Cells(.Rows.Count, 2)), _
.Rows.Count, .Cells(.Rows.Count, 2) _
.End(xlUp).Row) + 1
.Cells(lngLastRow, 1).Value = varTMP.Name
' Mit Pfad
'.Cells(lngLastRow, 1).Value = varTMP.Path
For intTMP = 4 To 7
With .Cells(lngLastRow, intTMP - 2)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheetQ1 & "'!" & strCellQ1 & intTMP
.Value = .Value
End With
Next intTMP
intCount = 0
For intTMP = 13 To 135 Step 2
strSpalte = Mid(.Columns(intTMP).Address, InStr _
(2, .Columns(intTMP).Address, "$") + 1)
With .Cells(lngLastRow, intCount + 6)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheetQ2 & "'!" & strSpalte & lngRow
.Value = .Value
intCount = intCount + 1
End With
Next intTMP
End With
End If
Next varTMP
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, True
Next varTMP
End If
Set objWorkbook = Nothing
End Sub
Private Function funcDirectory(strDirectory As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.Title = "Directory"
.ButtonName = "Select..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strDirectory = .SelectedItems(1)
If Right(strDirectory, 1) <> "\" Then _
strDirectory = strDirectory & "\"
Else
strDirectory = ""
End If
End With
funcDirectory = strDirectory
End Function


' Code gehört in Modul2

Option Explicit
' Die Tabelle wird ausgelesen
Const strSheetQ1 As String = "Tabelle1"
' Die Tabelle wird ausgelesen
Const strSheetQ2 As String = "Tabelle2"
' Die Tabelle in dieser Datei
Const strSheetZ As String = "Gesamt"
' Die Zelle wird ausgelesen
Const strCellQ1 As String = "C"
' Die Zelle mit dem Datum
Const strCellQ2 As String = "E3"
' Die Zeile in Tabelle2 wird ausgelesen
Const lngRow As Long = 10
Public Sub Files_Read_1()
Dim strListing As String
Dim intCalc 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
intCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Mit Ordnerauswahl - dann die entsprechenden unteren
' Codezeilen auskommentieren
' If funcDirectory(strDir) <> "" Then
' Set objDir = objFSO.GetFolder(strDir)
' ThisWorkbook.Worksheets(strSheetZ).Rows _
' ("2:" & Rows.Count).ClearContents
' 'dirInfo objDir, "*.xls*", True ' Mit Unterordner
' dirInfo objDir, "*.xls*"
' End If
' Datei im gleichen Ordner wie Auswertungsdateien
'strDir = ThisWorkbook.Path
' Datei im fest vorgegebenen Ordner
strDir = "C:\Temp\Test1"
Set objDir = objFSO.GetFolder(strDir)
ThisWorkbook.Worksheets(strSheetZ).Rows _
("2:" & Rows.Count).ClearContents
'dirInfo objDir, "*.xls*", True ' Mit Unterordner
dirInfo objDir, "*.xls*"
Fin:
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = intCalc
.DisplayAlerts = True
End With
Set objDir = Nothing
Set objFSO = Nothing
End Sub
Private 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 intCount As Integer
Dim strSpalte As String
Dim lngLastRow As Long
Dim intTMP As Integer
Dim varTMP As Variant
For Each varTMP In objCurrentDir.Files
If varTMP.Name Like strName And _
varTMP.Name <> ThisWorkbook.Name And _
Left(varTMP.Name, 1) <> "~" Then
With ThisWorkbook.Worksheets(strSheetZ)
lngLastRow = IIf(Len(.Cells(.Rows.Count, 2)), _
.Rows.Count, .Cells(.Rows.Count, 2) _
.End(xlUp).Row) + 1
.Cells(lngLastRow, 1).Value = varTMP.Name
' Mit Pfad
'.Cells(lngLastRow, 1).Value = varTMP.Path
For intTMP = 4 To 7
With .Cells(lngLastRow, intTMP - 2)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheetQ1 & "'!" & strCellQ1 & intTMP
.Value = .Value
End With
Next intTMP
intCount = 0
With .Cells(1, 5)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheetQ2 & "'!" & strCellQ2
.Value = .Value
.NumberFormat = "m/d/yyyy"
End With
For intTMP = 13 To 135 Step 2
strSpalte = Mid(.Columns(intTMP).Address, InStr _
(2, .Columns(intTMP).Address, "$") + 1)
With .Cells(lngLastRow, intCount + 6)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheetQ2 & "'!" & strSpalte & lngRow - 7
.Value = .Value
.NumberFormat = "m/d/yyyy"
With ThisWorkbook.Worksheets(strSheetZ)
If CLng(.Cells _
(lngLastRow, intCount + 6).Value) = _
CLng(.Cells _
(1, 5).Value) Then
.Cells(1, 5).ClearContents
Exit For
End If
End With
End With
Next intTMP
For intTMP = intTMP To 135 Step 2
strSpalte = Mid(.Columns(intTMP).Address, InStr _
(2, .Columns(intTMP).Address, "$") + 1)
With .Cells(lngLastRow, intCount + 6)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheetQ2 & "'!" & strSpalte & lngRow
.Value = .Value
.NumberFormat = "m/d/yyyy"
If .Cells(lngLastRow, intCount + 6) = _
.Cells(lngLastRow, intCount + 5) Then
intCount = intCount + 1
End If
End With
Next intTMP
End With
End If
Next varTMP
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, True
Next varTMP
End If
Set objWorkbook = Nothing
End Sub
Private Function funcDirectory(strDirectory As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.Title = "Directory"
.ButtonName = "Select..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strDirectory = .SelectedItems(1)
If Right(strDirectory, 1) <> "\" Then _
strDirectory = strDirectory & "\"
Else
strDirectory = ""
End If
End With
funcDirectory = strDirectory
End Function

25.03.2011

UserForm - Suchen - Ändern - Neu anlegen!

Frage aus dem Herber-Forum: Über eine UserForm soll in einem Tabellenblatt in Spalte A der in einer TextBox1 eingegebene Wert gesucht werden. Wird er gefunden soll in TextBox2 der korrespondierende Wert aus Spalte B angezeigt werden. Änderungen können nun vorgenommen und anschließend in das Tabellenblatt an die entsprechende Stelle zurück gespeichert werden. Ist der Wert nicht vorhanden, soll er am Ende neu angelegt werden.

UserForm - Suchen - Ändern - Neu anlegen...[ZIP, 60 KB]

' Code gehört in UserForm1

Option Explicit
Private Sub TextBox1_Change()
Dim varTMP As Variant
With Tabelle2
varTMP = Application.Match(TextBox1.Text, .Range("A:A"), 0)
If Not IsError(varTMP) Then
Me.Tag = varTMP
TextBox2.Text = .Cells(varTMP, 2).Value
Else
Me.Tag = ""
TextBox2.Text = ""
End If
End With
End Sub
Private Sub CommandButton1_Click()
Dim lngRow As Long
If Trim(TextBox1.Text) <> "" And Trim(TextBox2.Text) <> "" Then
If Me.Tag <> "" Then
With Tabelle2
.Cells(Me.Tag, 1).Value = TextBox1.Text
.Cells(Me.Tag, 2).Value = TextBox2.Text
End With
Else
With Tabelle2
lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(lngRow, 1) = TextBox1.Text
.Cells(lngRow, 2) = TextBox2.Text
End With
End If
TextBox1.Text = ""
TextBox2.Text = ""
Else
MsgBox ("Eingabe unvollständig!")
TextBox1.SetFocus
End If
End Sub
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii >= Asc("a") And KeyAscii <= Asc("z") Then _
KeyAscii = KeyAscii + Asc("A") - Asc("a")
End Sub
Private Sub TextBox2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii >= Asc("a") And KeyAscii <= Asc("z") Then _
KeyAscii = KeyAscii + Asc("A") - Asc("a")
End Sub

24.03.2011

API - Timer - Tabellenblattschutz prüfen!

Frage aus Office-Loesung: Kann man das Setzen bzw. Aufheben des Tabellenblattschutzes überwachen? Ja - das geht per API. Wird der Tabellenblattschutz aufgehoben, dann wird der CommandButton ROT, sonst Grün.

API - Timer - Tabellenblattschutz prüfen...[ZIP, 50 KB]

Hinweise:
API - Set Timer

API - Kill Timer

Option Explicit
Private Declare Function KillTimer Lib "user32.dll" _
(ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function SetTimer Lib "user32.dll" _
(ByVal hWnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public lngTimer As Long
Sub SchutzAktiv(ByVal hWnd As Long, ByVal lngMsg As Long, _
ByVal lngEla As Long, ByVal lngFunc As Long)
If lngMsg = &H113 Then
With Tabelle1
.CommandButton1.BackColor = IIf(Not .ProtectContents, &HFF&, &HC000&)
End With
End If
End Sub
Sub StartT()
lngTimer = SetTimer(0, 0, 300, AddressOf SchutzAktiv)
End Sub
Sub StopT()
KillTimer 0, lngTimer
End Sub

15.03.2011

UserForm - Zahlen - Komma -Tabellenblatt!

Frage: Wie kann man über eine UserForm Zahlen und Komma in Zellen eingeben? Die Windowsinterne Bildschirmtastatur (OSK) soll nicht verwendet werden. So:

UserForm - Zahlen - Komma -Tabellenblatt...[ZIP, 60 KB]

'Code in "DieseArbeitsmappe":

Option Explicit
Private Sub Workbook_Open()
UserForm1.Show 0
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call Terminate_Class
End Sub

'Code in ein Modul:

Option Explicit
Private objButton() As clsButton
Public Sub Terminate_Class()
Dim lngIndex As Long
If IsArray(objButton) Then
For lngIndex = LBound(objButton) To UBound(objButton)
Set objButton(lngIndex) = Nothing
Next
End If
Erase objButton
End Sub

'Code in "UserForm1":

Option Explicit
Private objButton() As clsButton
Private Sub UserForm_Activate()
Dim objControl As Control
Dim lngCounter As Long
For Each objControl In Controls
If TypeOf objControl Is MSForms.CommandButton Then
ReDim Preserve objButton(0 To lngCounter)
Set objButton(lngCounter) = New clsButton
Set objButton(lngCounter).SetButton = objControl
lngCounter = lngCounter + 1
End If
Next objControl
End Sub
Private Sub Label1_Click()
Unload Me
End Sub

'Code in einem Klassenmodul mit Namen "clsButton":

Option Explicit
Private WithEvents mobjButton As MSForms.CommandButton
Friend Property Set SetButton(objButton As MSForms.CommandButton)
Set mobjButton = objButton
End Property
Private Sub mobjButton_Click()
With ActiveSheet.Cells(ActiveCell.Row, ActiveCell.Column)
.Value = .Value & mobjButton.Caption
End With
If Not mobjButton.Caption = "," Then
ActiveSheet.Columns(ActiveCell.Column).TextToColumns
End If
End Sub

01.03.2011

Worddateien durchsuchen - auch mit Passwort!

Einen älteren Blogeintrag etwas angepasst. In Worddateien - optional auch in Unterordnern - soll ein bestimmter Begriff gesucht werden. Wird der Begriff im Worddokument gefunden, soll das Dokument aufgelistet und mit einem Hyperlink versehen werden. Die Worddokumente können auch ein Kennwort haben, dass beim Öffnen verlangt wird.

Worddateien durchsuchen - auch mit Passwort...[ZIP, 280 KB]

Option Explicit
Private Declare Function GetCurrentDirectory Lib "kernel32" _
Alias "GetCurrentDirectoryA" _
(ByVal nBufferLength&, ByVal lpBuffer$) As Long
Private Declare Function SetCurrentDirectory Lib "kernel32" _
Alias "SetCurrentDirectoryA" _
(ByVal lpPathName$) As Long
Const strSearchTMP As String = "Calculation"
Const strEXT As String = "*.doc*"
Private strList() As String
Private objWDApp As Object
Private lngCount As Long
Private objFSO As Object
Public Sub Test()
Dim strListing As String
Dim strDirOld As String
lngCount = 0
On Error GoTo Fin
strDirOld$ = String(255, 0)
Call GetCurrentDirectory(255, strDirOld$)
strDirOld$ = Left(strDirOld$, _
InStr(1, strDirOld$, vbNullChar) - 1)
If funcDirectory(strListing) <> "" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objWDApp = CreateObject("Word.Application")
Select Case MsgBox _
("Mit Unterordner ""Ja"" klicken, sonst ""Nein""!", _
vbYesNo Or vbQuestion Or vbDefaultButton1, "Unterordner")
Case vbYes
SearchFiles strListing, strEXT, True
Case vbNo
SearchFiles strListing, strEXT
End Select
If lngCount = 0 Then
MsgBox "No file with the search value found."
Else
With Sheet1
.Cells.Clear
.Range(.Cells(1, 1), Cells(lngCount, 1)) = _
WorksheetFunction.Transpose(strList)
End With
Call HyLink(Sheet1)
End If
End If
Fin:
If Not objWDApp Is Nothing Then objWDApp.Quit
Call SetCurrentDirectory(strDirOld$)
Set objWDApp = Nothing
Set objFSO = Nothing
End Sub
Private Sub SearchFiles(strFolder As String, strFileName As String, _
Optional blnTMP As Boolean = False)
Dim objFolder As Object
Dim objFile As Object
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Name Like strFileName Then
objWDApp.Documents.Open objFile.Path, _
PasswordDocument:="12345"
With objWDApp.Selection.Find
.Forward = True
.Text = strSearchTMP
If .Execute = True Then
ReDim Preserve strList(lngCount)
strList(lngCount) = objFile.Path
lngCount = lngCount + 1
objWDApp.ActiveDocument.Close False
End If
End With
End If
Next
If blnTMP = True Then
For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
SearchFiles strFolder & "\" & objFolder.Name, _
strFileName, blnTMP
Next
End If
End Sub
Private Function funcDirectory(strDirectory As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.Title = "Directory"
.ButtonName = "Select..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strDirectory = .SelectedItems(1)
If Right(strDirectory, 1) <> "\" _
Then strDirectory = strDirectory & "\"
funcDirectory = strDirectory
Else
funcDirectory = ""
End If
End With
End Function
Private Sub HyLink(objSheet As Object)
Dim lngRow As Long
With objSheet
lngRow = .Range("A" & .Rows.Count).End(xlUp).Row
For lngRow = 1 To lngRow
.Hyperlinks.Add Anchor:=.Cells(lngRow, 2), _
Address:=.Cells(lngRow, 1), _
TextToDisplay:=Mid(.Cells(lngRow, 1), _
InStrRev(.Cells(lngRow, 1), "\", -1) + 1)
Next lngRow
.Columns("A:B").AutoFit
End With
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 ...