23.06.2009

Address - Filter - Find!

Der Autofilter filtert über VBA Adressdaten. Auf Tabellenblatt 2 und 3 werden die nicht passenden Zeilen über die Find-Funktion ausgeblendet. In Tabellenblatt 3 können mehrere Suchbegriffe kommagetrennt einegegeben werden. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007. Der folgende Code gehört in "Tabelle1, Tabelle2 und Tabelle3".


Option Explicit
Public Sub CommandButton1_Click()
Dim objButton As OLEObject
For Each objButton In ActiveSheet.OLEObjects
If Left(objButton.Name, 7) = "TextBox" Then
objButton.Object.Value = ""
End If
Next objButton
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
End Sub
Private Sub TextBox1_Change()
If TextBox1.Text = "" Then
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
Else
Selection.AutoFilter Field:=1, Criteria1:="=" _
& Me.TextBox1 & "*", Operator:=xlAnd
'Selection.AutoFilter Field:=1, Criteria1:="**" _
' & Me.TextBox1 & "*", Operator:=xlAnd
'If you use the out-commentated code line
'not only for the initial letter is searched,
'but in the text. Give it a try.
End If
End Sub
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = vbKeySpace Then KeyAscii = 0
End Sub
Private Sub TextBox2_Change()
If TextBox2.Text = "" Then
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
Else
Selection.AutoFilter Field:=2, Criteria1:="=" _
& Me.TextBox2 & "*", Operator:=xlAnd
'Selection.AutoFilter Field:=2, Criteria1:="**" _
' & Me.TextBox2 & "*", Operator:=xlAnd
'If you use the out-commentated code line
'not only for the initial letter is searched,
'but in the text. Give it a try.
End If
End Sub
Private Sub TextBox2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = vbKeySpace Then KeyAscii = 0
End Sub
Private Sub TextBox3_Change()
If TextBox3.Text = "" Then
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
Else
Selection.AutoFilter Field:=3, Criteria1:="=" _
& Me.TextBox3 & "*", Operator:=xlAnd
'Selection.AutoFilter Field:=3, Criteria1:="**" _
' & Me.TextBox3 & "*", Operator:=xlAnd
'If you use the out-commentated code line
'not only for the initial letter is searched,
'but in the text. Give it a try.
End If
End Sub
Private Sub TextBox3_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = vbKeySpace Then KeyAscii = 0
End Sub
Private Sub TextBox4_Change()
If TextBox4.Text = "" Then
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
Else
Selection.AutoFilter Field:=4, Criteria1:="=" _
& Me.TextBox4 & "*", Operator:=xlAnd
'Selection.AutoFilter Field:=4, Criteria1:="**" _
' & Me.TextBox4 & "*", Operator:=xlAnd
'If you use the out-commentated code line
'not only for the initial letter is searched,
'but in the text. Give it a try.
End If
End Sub
Private Sub TextBox4_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = vbKeySpace Then KeyAscii = 0
End Sub


Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim strFirst As String
Dim lngColumn As Long
Dim rngUnion As Range
Dim rngFound As Range
Dim rngTMP As Range
Dim lngRow As Long
On Error GoTo Fin
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Cells(1, 2)) Is Nothing Then
If Trim(Target.Value) = "" Then _
Cells.EntireRow.Hidden = False: Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
lngRow = IIf(Len(Cells(Rows.Count, 1)), Rows.Count, _
Cells(Rows.Count, 1).End(xlUp).Row)
lngColumn = Cells.Find _
("*", , , , xlByColumns, xlPrevious).Column
Set rngTMP = Range(Cells(3, 1), Cells(lngRow, lngColumn))
Set rngFound = rngTMP.Find(Cells(1, 2).Text, _
After:=Range("A3"), LookIn:=xlValues, LookAt:=xlPart)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Do
If Not rngUnion Is Nothing Then
Set rngUnion = Application.Union(rngUnion, _
Cells(rngFound.Row, 1)).EntireRow
Else
Set rngUnion = Cells(rngFound.Row, 1).EntireRow
End If
Set rngFound = rngTMP.FindNext(rngFound)
Loop While rngFound.Address <> strFirst
Else
Target.ClearContents
MsgBox "Nothing found!"
End If
Else
Exit Sub
End If
Application.Goto Range("B1")
If Not rngUnion Is Nothing Then
rngTMP.Rows.Hidden = True
rngUnion.Hidden = False
End If
Fin:
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
Application.ScreenUpdating = True
Application.EnableEvents = True
Set rngUnion = Nothing
Set rngFound = Nothing
Set rngTMP = Nothing
End Sub


Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim strFirst As String
Dim varTerm As Variant
Dim intTMP As Integer
Dim lngColumn As Long
Dim rngUnion As Range
Dim rngFound As Range
Dim rngTMP As Range
Dim lngRow As Long
On Error GoTo Fin
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Cells(1, 2)) Is Nothing Then
If Trim(Target.Value) = "" Then _
Cells.EntireRow.Hidden = False: Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
lngRow = IIf(Len(Cells(Rows.Count, 1)), Rows.Count, _
Cells(Rows.Count, 1).End(xlUp).Row)
lngColumn = Cells.Find _
("*", , , , xlByColumns, xlPrevious).Column
Set rngTMP = Range(Cells(3, 1), Cells(lngRow, lngColumn))
varTerm = Split(Cells(1, 2).Text, ",")
For intTMP = 0 To Ubound(varTerm)
Set rngFound = rngTMP.Find(varTerm(intTMP), _
After:=Range("A3"), LookIn:=xlValues, LookAt:=xlPart)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Do
If Not rngUnion Is Nothing Then
Set rngUnion = Application.Union(rngUnion, _
Cells(rngFound.Row, 1)).EntireRow
Else
Set rngUnion = Cells(rngFound.Row, 1).EntireRow
End If
Set rngFound = rngTMP.FindNext(rngFound)
Loop While rngFound.Address <> strFirst
Else
Target.ClearContents
MsgBox "Nothing found!"
End If
Next intTMP
Else
Exit Sub
End If
Application.Goto Range("B1")
If Not rngUnion Is Nothing Then
rngTMP.Rows.Hidden = True
rngUnion.Hidden = False
End If
Fin:
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
Application.ScreenUpdating = True
Application.EnableEvents = True
Set rngUnion = Nothing
Set rngFound = Nothing
Set rngTMP = Nothing
End Sub


Sample 2003

Sample 2007

13.06.2009

UserForm - Save - TIF - GIF - JPG!

A user form is to be stored as a file. There are the formats "TIF", "GIF" and "JPG". The problem is over "PowerPoint" solved. The files at the end of the article are Excelfiles of the version 2003 and 2007. The following code belonged in "UserForm1, UserForm2 and Module1".


Eine UserForm soll als Datei gespeichert werden. Es gibt die Formate "TIF", "GIF" und "JPG". Das Problem wird über "PowerPoint" gelöst. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007. Der folgende Code gehört in "UserForm1, UserForm2 und Modul1".


Option Explicit
Private Declare Function MapVirtualKey Lib "user32" _
Alias "MapVirtualKeyA" (ByVal wCode As Long, _
ByVal wMapType As Long) As Long
Private Declare Sub keybd_event Lib "user32" _
(ByVal bVk As Byte, ByVal bScan As Byte, _
ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Sub CommandButton1_Click()
'vbKeySnapshot -> Print = &H2C and ALT = &H12
UserForm2.Show
Me.Repaint
keybd_event &H12, MapVirtualKey(&H12, 0), 0, 0
keybd_event &H2C, 0, 0, 0
DoEvents
keybd_event &H12, MapVirtualKey(&H12, 0), 2, 0
Call UF_PP
Unload Me
If Not UserForm2 Is Nothing Then Unload UserForm2
UserForm1.Show
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub UserForm_Activate()
Me.OptionButton2.Value = True
Me.CheckBox2.Value = True
Me.CheckBox4.Value = True
Me.ListBox1.AddItem "ListBox1"
Me.ListBox2.AddItem "ListBox2"
End Sub


Option Explicit
Private Sub OptionButton1_Click()
Me.Tag = 1
Me.Hide
End Sub
Private Sub OptionButton2_Click()
Me.Tag = 2
Me.Hide
End Sub
Private Sub OptionButton3_Click()
Me.Tag = 3
Me.Hide
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then Cancel = True
End Sub


Option Explicit
Public Sub UF_PP()
Dim objPPRange As Object
Dim objPPApp As Object
Dim objSlide As Object
Dim strTMP As String
Dim strEX As String
On Error GoTo Fin
Application.ScreenUpdating = False
strTMP = Sheet1.Cells(1, 1).Text
Select Case UserForm2.Tag
Case 1
strEX = "TIF"
Case 2
strEX = "GIF"
Case 3
strEX = "JPG"
End Select
Set objPPApp = CreateObject("PowerPoint.Application")
With objPPApp
.Visible = True
.WindowState = 2
.Presentations.Add
.ActivePresentation.Slides.Add 1, 12
Set objSlide = .ActivePresentation.Slides(1)
Set objPPRange = objSlide.Shapes.Paste
With objPPRange
.LockAspectRatio = False
.Width = objSlide.Design.SlideMaster.Width
.Height = objSlide.Design.SlideMaster.Height
.Align 4, True
.Align 1, True
End With
objSlide.Export "D:\Temp\" & strTMP & "." & _
strEX, strEX ' adapt / anpassen
.Quit
End With
Fin:
Application.ScreenUpdating = True
Set objPPRange = Nothing
Set objSlide = Nothing
Set objPPApp = Nothing
End Sub


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


Sample 2003

Sample 2007

Everything Divide Column A!

All same values from sheet "Master" column A are distributed on worksheets. The worksheets are provided. With repetitive call of the code the provided worksheets are deleted and again provided. The example works with 6000 (29 different) values and autofilters. The column A is not sorted. The files at the end of the article are Excelfiles of the version 2003 and 2007. The following code belonged in "Module1".


Alle gleichen Werte aus Tabellenblatt "Master" Spalte A sollen auf Tabellenblätter verteilt werden. Die Tabellenblätter werden erstellt. Bei wiederholtem Aufruf des Codes werden die erstellten Tabellenblätter gelöscht und neu erstellt. Das Beispiel arbeitet mit 6000 (29 unterschiedlichen) Werten und Autofilter. Die Spalte A ist nicht sortiert. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007. Der folgende Code gehört in "Modul1".


Option Explicit
Public Sub Everything_Divide()
Dim wksSheet As Worksheet
Dim wksTMP As Worksheet
Dim rngRange As Range
Dim rngTMP As Range
Dim lngRow As Long
On Error GoTo Fin
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wksSheet = ThisWorkbook.Worksheets("Master")
For Each wksTMP In ThisWorkbook.Worksheets
If wksTMP.Name Like "ID*" Then
wksTMP.Delete
End If
Next wksTMP
Set wksTMP = Worksheets.Add
wksSheet.UsedRange.Copy wksTMP.Range("A1")
With wksTMP
Set rngRange = .Range("A1").CurrentRegion
rngRange.Sort Key1:=.Range("A2"), _
Order1:=xlAscending, Header:=xlYes
lngRow = 2
Do Until IsEmpty(rngRange.Cells(lngRow, 1))
If rngRange.Cells(lngRow, 1) <> _
rngRange.Cells(lngRow - 1, 1) Then
rngRange.AutoFilter field:=1, _
Criteria1:=rngRange.Cells(lngRow, 1)
Set rngTMP = rngRange.SpecialCells(xlCellTypeVisible)
Worksheets.Add.Move _
After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "ID_" & rngRange.Cells(lngRow, 1)
rngTMP.Copy Range("A1")
End If
lngRow = lngRow + 1
Loop
End With
Fin:
If Not wksTMP Is Nothing Then wksTMP.Delete
Application.Goto Reference:=wksSheet.Cells(1, 1), Scroll:=True
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
If Not wksSheet Is Nothing Then wksSheet.AutoFilterMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub


Sample 2003

Sample 2007

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 ...