31.01.2011

Zelle - Blinken - Font- - Hintergrundfarbe!

Auch immer wieder ein Thema in den Excelforen - blinkende Zellen. Je nach Wert soll eine Zelle blinken. Entweder der Hintergrund, oder die Schrift. Auch ein Kriterium: Die Änderung kann entweder über Eingabe in diese Zelle erfolgen oder über eine Formel. Man sieht in dem Beispiel auch, wie das "Worksheet_Change-Ereignis" über das "Worksheet_Calculate-Ereignis" aufgerufen wird.

Zelle - Blinken - Font- - Hintergrundfarbe...[ZIP, 80 KB]

Folgender Code gehört in "DieseArbeitsmappe":

Option Explicit
Private Sub Workbook_Deactivate()
On Error Resume Next
Call Ende
Call Ende_1
Call Ende_2
Call Ende_3
End Sub


Folgender Code gehört in ein Modul mit Namen "Blinken_2":

Option Explicit
Public varZeit2 As Variant
Public Sub Farbe_Eins_2()
ThisWorkbook.Worksheets("Beispiel_3") _
.Range("A1").Font.ColorIndex = 3
varZeit2 = Now + TimeValue("00:00:01")
Application.OnTime varZeit2, "Farbe_Zwei_2"
End Sub
Public Sub Farbe_Zwei_2()
ThisWorkbook.Worksheets("Beispiel_3") _
.Range("A1").Font.ColorIndex = 5
varZeit2 = Now + TimeValue("00:00:01")
Application.OnTime varZeit2, "Farbe_Eins_2"
End Sub
Public Sub Ende_2()
On Error Resume Next
Application.OnTime EarliestTime:=varZeit2, _
Procedure:="Farbe_Eins_2", Schedule:=False
Application.OnTime EarliestTime:=varZeit2, _
Procedure:="Farbe_Zwei_2", Schedule:=False
varZeit2 = ""
ThisWorkbook.Worksheets("Beispiel_3") _
.Range("A1").Font.ColorIndex = xlAutomatic
End Sub


Folgender Code gehört in ein Modul mit Namen "Blinken":

Option Explicit
Public varZeit As Variant
Public Sub Farbe_Eins()
ThisWorkbook.Worksheets("Beispiel_1") _
.Range("A1").Interior.ColorIndex = 19
varZeit = Now + TimeValue("00:00:01")
Application.OnTime varZeit, "Farbe_Zwei"
End Sub
Public Sub Farbe_Zwei()
ThisWorkbook.Worksheets("Beispiel_1") _
.Range("A1").Interior.ColorIndex = 42
varZeit = Now + TimeValue("00:00:01")
Application.OnTime varZeit, "Farbe_Eins"
End Sub
Public Sub Ende()
On Error Resume Next
Application.OnTime EarliestTime:=varZeit, _
Procedure:="Farbe_Eins", Schedule:=False
Application.OnTime EarliestTime:=varZeit, _
Procedure:="Farbe_Zwei", Schedule:=False
varZeit = ""
ThisWorkbook.Worksheets("Beispiel_1") _
.Range("A1").Interior.ColorIndex = xlNone
End Sub


Folgender Code gehört in ein Modul mit Namen "Blinken_1":

Option Explicit
Public varZeit1 As Variant
Public Sub Farbe_Eins_1()
ThisWorkbook.Worksheets("Beispiel_2") _
.Range("A1").Interior.ColorIndex = 19
varZeit1 = Now + TimeValue("00:00:01")
Application.OnTime varZeit1, "Farbe_Zwei_1"
End Sub
Public Sub Farbe_Zwei_1()
ThisWorkbook.Worksheets("Beispiel_2") _
.Range("A1").Interior.ColorIndex = 42
varZeit1 = Now + TimeValue("00:00:01")
Application.OnTime varZeit1, "Farbe_Eins_1"
End Sub
Public Sub Ende_1()
On Error Resume Next
Application.OnTime EarliestTime:=varZeit1, _
Procedure:="Farbe_Eins_1", Schedule:=False
Application.OnTime EarliestTime:=varZeit1, _
Procedure:="Farbe_Zwei_1", Schedule:=False
varZeit1 = ""
ThisWorkbook.Worksheets("Beispiel_2") _
.Range("A1").Interior.ColorIndex = xlNone
End Sub


Folgender Code gehört in ein Modul mit Namen "Blinken_3":

Option Explicit
Public varZeit3 As Variant
Public Sub Farbe_Eins_3()
ThisWorkbook.Worksheets("Beispiel_4") _
.Range("A1").Font.ColorIndex = 3
varZeit3 = Now + TimeValue("00:00:01")
Application.OnTime varZeit3, "Farbe_Zwei_3"
End Sub
Public Sub Farbe_Zwei_3()
ThisWorkbook.Worksheets("Beispiel_4") _
.Range("A1").Font.ColorIndex = 5
varZeit3 = Now + TimeValue("00:00:01")
Application.OnTime varZeit3, "Farbe_Eins_3"
End Sub
Public Sub Ende_3()
On Error Resume Next
Application.OnTime EarliestTime:=varZeit3, _
Procedure:="Farbe_Eins_3", Schedule:=False
Application.OnTime EarliestTime:=varZeit3, _
Procedure:="Farbe_Zwei_3", Schedule:=False
varZeit3 = ""
ThisWorkbook.Worksheets("Beispiel_4").Range("A1") _
.Font.ColorIndex = xlAutomatic
End Sub


Folgender Code gehört in ein Modul mit Namen "Farben":

Option Explicit
Sub Farben_Nummern()
Dim intZahl As Integer
For intZahl = 1 To 56
With Tabelle6
.Cells(intZahl, 1) = intZahl
.Cells(intZahl, 2).Interior.ColorIndex = intZahl
End With
Next
End Sub


Folgender Code gehört in das Klassenmodul der Tabelle2:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$A$1" Then Exit Sub
If Range("A1").Value >= 22 Then
Call Farbe_Eins
Else
Call Ende
End If
End Sub


Folgender Code gehört in das Klassenmodul der Tabelle3:

Option Explicit
Private Sub Worksheet_Calculate()
Call Worksheet_Change(ActiveCell)
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Range("A1").Value >= 22 Then
Call Farbe_Eins_1
Else
Call Ende_1
End If
End Sub


Folgender Code gehört in das Klassenmodul der Tabelle4:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$A$1" Then Exit Sub
If Range("A1").Value >= 22 Then
Call Farbe_Eins_2
Else
Call Ende_2
End If
End Sub


Folgender Code gehört in das Klassenmodul der Tabelle2:

Option Explicit
Private Sub Worksheet_Calculate()
Call Worksheet_Change(ActiveCell)
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Range("A1").Value >= 22 Then
Call Farbe_Eins_3
Else
Call Ende_3
End If
End Sub

25.01.2011

API - UserForm - Excelfenster!

Frage aus Office-Loesung: Wie kann man bei einer ungebunden geladenen UserForm (UserForm1.Show 0) nach Klick auf z. B. einen CommandButton ohne mit der Maus in das Tabellenblatt zu klicken gleich im Tabellenblatt mit der Tabtaste navigieren? Realisiert über die API-Funktionen "FindWindow" und "BringWindowToTop":

API - UserForm - Excelfenster...[ZIP, 50 KB]

Code gehört in Modul1:

Option Explicit
Sub UF_Show()
UserForm1.Show 0
End Sub


Code gehört in das Klassenmodul UserForm:

Option Explicit
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function BringWindowToTop Lib "user32.dll" _
(ByVal hwnd As Long) As Long
Private Sub CommandButton1_Click()
Dim lngTMP As Long
lngTMP = FindWindow("XLMAIN", vbNullString)
BringWindowToTop lngTMP
End Sub

18.01.2011

Geschlossene Dateien - UserForm - InputBox!

Es ist ein weit verbreitetes, aber auch interessantes Thema: Geschlossene Dateien auslesen. Im Folgenden mit einer UserForm bzw. einer InputBox. Hier werden die Abfragen nach Bereich, Tabelle und Unterordner geregelt.

Geschlossene Dateien - Range oder Zelle - UserForm - InputBox...[ZIP, 260 KB]

Der folgende Code gehört in "DieseArbeitsmappe":

Option Explicit
Private Sub Workbook_Deactivate()
Unload UserForm1
End Sub



Der folgende Code gehört in "UserForm1":

Option Explicit
Private Sub UserForm_Activate()
CheckBox1.Value = False
CheckBox2.Value = False
TextBox2.Text = "A1:C30"
TextBox3.Text = "Tabelle1"
Me.Tag = ""
End Sub
Private Sub TextBox1_DblClick(ByVal Cancel As _
MSForms.ReturnBoolean)
Dim strTMP As String
TextBox1.Text = funcDirectory(strTMP)
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
Private Sub CommandButton1_Click()
If CheckBox2.Value = False Then Me.Tag = "q"
Me.Hide
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, _
CloseMode As Integer)
If CloseMode = 0 Then Cancel = True
End Sub



Der folgende Code gehört in "Modul1":

Option Explicit
' Die Tabelle in DIESER Datei
Const strSheetZ As String = "Gesamt"
Dim strSheetQ As String
Dim strRange As String
Public Sub Files_Read()
Dim stCalc As Integer
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
UserForm1.Show
If UserForm1.Tag = "q" Then Exit Sub
strRange = UserForm1.TextBox2.Text
strSheetQ = UserForm1.TextBox3.Text
If Trim(UserForm1.TextBox1.Text) = "" Then
strDir = ThisWorkbook.Path
Else
strDir = UserForm1.TextBox1.Text
End If
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
stCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objDir = objFSO.GetFolder(strDir)
If UserForm1.CheckBox1.Value = True Then
dirInfo objDir, "*.xls*", True
Else
dirInfo objDir, "*.xls*"
End If
Fin:
With Application
.Goto (ThisWorkbook.Worksheets _
(strSheetZ).Range("A1")), True
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = stCalc
.DisplayAlerts = True
End With
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 varTMP As Variant
Dim strTMP As String
strTMP = Range(strRange).Address(RowAbsolute:=True, _
ColumnAbsolute:=True, ReferenceStyle:=xlR1C1)
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, 1)), _
.Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
With .Range(.Cells(lngLastRow, 1), _
.Cells(Range(strRange).Rows.Count + lngLastRow - 1, _
Range(strRange).Columns.Count))
.FormulaArray = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheetQ & "'!" & strRange
End With
.UsedRange.Value = .UsedRange.Value
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



Der folgende Code gehört in "Modul2":

Option Explicit
' DIE Tabelle wird ausgelesen"
Const strSheetQ As String = "Tabelle1"
' Die Tabelle in DIESER Datei
Const strSheetZ As String = "Gesamt"
Dim strRange As String
Public Sub Files_Read1()
Dim stCalc As Integer
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
Select Case MsgBox("Ordner auswählen? Bei ""Nein"" wird " & _
"das Verzeichnis mit DIESER Datei genommen!", vbYesNoCancel Or _
vbQuestion Or vbDefaultButton2, "Auswahl")
Case vbYes
If Not funcDirectory(strDir) <> "" Then
MsgBox "Kein Verzeichnis ausgewählt!": Exit Sub
End If
Case vbNo
strDir = ThisWorkbook.Path
Case vbCancel
Exit Sub
End Select
strRange = InputBox("Welcher Bereich?", "Range", "A1:C30")
If Trim(strRange) = "" Then Exit Sub
With Application
.AskToUpdateLinks = False
.EnableEvents = False
stCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objDir = objFSO.GetFolder(strDir)
Select Case MsgBox("MIT UNterordner?", vbYesNo Or _
vbQuestion Or vbDefaultButton2, "Auswahl")
Case vbYes
dirInfo objDir, "*.xls*", True
Case vbNo
dirInfo objDir, "*.xls*"
End Select

Fin:
With Application
.Goto (ThisWorkbook.Worksheets _
(strSheetZ).Range("A1")), True
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = stCalc
.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 lngLastRow As Long
Dim varTMP As Variant
Dim strTMP As String
Application.ScreenUpdating = False
strTMP = Range(strRange).Address(RowAbsolute:=True, _
ColumnAbsolute:=True, ReferenceStyle:=xlR1C1)
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, 1)), _
.Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
With .Range(.Cells(lngLastRow, 1), _
.Cells(Range(strRange).Rows.Count + lngLastRow - 1, _
Range(strRange).Columns.Count))
.FormulaArray = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheetQ & "'!" & strRange
End With
.UsedRange.Value = .UsedRange.Value
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

17.01.2011

Bild - Position - auf allen Tabellenblättern gleich!

Die Position eines Bildes soll auf allen Tabellenblättern immer gleich sein, egal auf welchem Tabellanblatt ich es verschiebe.

Bild - Position - auf allen Tabellenblättern gleich...[ZIP, 100 KB]

Code gehört in "DieseArbeitsmappe":

Option Explicit
Const strShape As String = "Auto" ' Anpassen !!!
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
On Error Resume Next
Application.ScreenUpdating = False
With Sh
.Shapes(strShape).Delete
.Paste
.Shapes(strShape).Top = lngRow
.Shapes(strShape).Left = lngColumn
End With
On Error GoTo Fin
Fin:
With Application
.Goto Sh.Range("A1"), True
.ScreenUpdating = True
.CutCopyMode = False
End With
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
On Error Resume Next
lngRow = Sh.Shapes(strShape).Top
lngColumn = Sh.Shapes(strShape).Left
Sh.Shapes(strShape).Copy
End Sub


Code gehört in ein "Modul":

Option Explicit
Public lngColumn As Long
Public lngRow As Long

14.01.2011

Geschlossene Datei - Zelle auslesen!

Im Herber Forum gefragt: Eine Exceldatei gleichen Aufbaus ist in verschiedenen Ordnern abgelegt. Alle aber unter einem "Oberordner". Nun soll nach Eingabe des Ordners in Zelle A2 der Inhalt von z. B. D10 aus der jeweiligen Datei ausgelesen werden. Diese soll dabei geschlossen bleiben. Also:

In die Zelle A2 entweder "Test1", "Test2", "Test3" oder "Test4" schreiben!
Klein- Großschreibung ist egal.
Test1-4 sind Ordner - alle unter "Thisworkbook.Path" - in denen jeweils dieselbe Datei ist.
Aus dieser Datei wird eine bestimmte Zelle ausgelesen und in A3 angezeigt
Bei Eingabe eines nicht vorhandenen Ordners erscheint der Datei-Öffnen-Dialog.


Erklärungen auch im Download.

Geschlossene Datei - Zelle auslesen - WorkSheet_Change...[ZIP, 70 KB]

Option Explicit
Const strSheet As String = "Tabelle1" ' Anpassen!!!
Const strFile As String = "Rapport.xls" ' Anpassen!!!
Const strCell As String = "D10" ' Anpassen!!!
'Const strPath As String = "C:\Temp\" ' Anpassen!!!
Private Sub Worksheet_Change(ByVal Target As Range)
Dim strPath As String
On Error GoTo Fin
strPath = ThisWorkbook.Path & "\"
If Target.Count > 1 Then Exit Sub
Application.EnableEvents = False
If Not Intersect(Target, Range("A2")) Is Nothing Then
If Trim(Target.Value) <> "" Then
With Me
.Range("A3").Formula = "='" & strPath & _
.Range("A2").Value & "\" & "[" & _
strFile & "]" & strSheet & "'!" & strCell
.Range("A3").Value = .Range("A3").Value
End With
Else
Me.Range("A3").ClearContents
End If
End If
Fin:
Application.EnableEvents = True
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 ...