27.03.2009

Search - Copy - Offset!

The following code is searched for a term and a cell on the right of the find cell is copied in a new sheet. The parameters are optional. Also the find cell, a cell left, right, above or down and/or further can be copied. The files at the end of the article are Excelfiles of the version 2003 and 2007. The following code belonged in a "Module."


Im folgenden Code wird nach einem Begriff gesucht und eine Zelle rechts der Fundstelle in einem neuen Tabellenblatt ausgegeben. Die Parameter sind Optional. Es kann auch die Fundzelle, eine Zelle links, rechts, oben oder unten bzw. weitere ausgegeben werden. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007. Der folgede Code gehört in ein "Modul."


Option Explicit
Public Sub Test()
' a cell right - eine Zelle rechts
Call subSearch(, 1)

' the find cell - die FundZelle
'Call subSearch

'a cell right AND down. - eine Zelle rechts UND runter
'Call subSearch(1, 1)

' a cell down
'Call subSearch(-1)

' a cell up - eine Zelle hoch
'Call subSearch(1)

' a cell left - eine Zelle links
'Call subSearch(, -1)

' a cell left AND up - eine Zelle links UND hoch
'Call subSearch(-1, -1)
End Sub
Private Sub subSearch(Optional lngRow As Long = 0, _
Optional lngColumn As Long = 0)
Dim wksSheet As Worksheet
Dim strFound As String
Dim rngFound As Range
Dim strTMP As String
strTMP = InputBox("Search", "Search", "A_1")
If strTMP = "" Then Exit Sub
With Sheet1.Cells
Set rngFound = .Find(What:=strTMP, LookIn:=xlValues, LookAt:=xlWhole)
If Not rngFound Is Nothing Then
Set wksSheet = Worksheets.Add
strFound = rngFound.Address
Do
If Not rngFound.Row = 1 Or Left(lngRow, 1) <> "-" Then
If Not rngFound.Column = 1 Or _
Left(lngColumn, 1) <> "-" Then
If Not rngFound.Row = .Rows.Count Or _
Left(lngRow, 1) <> "-" Then
If Not rngFound.Column = 1 Or _
Left(lngColumn, 1) <> "-" Then
wksSheet.Range("A" & wksSheet.Rows.Count). _
End(xlUp).Offset _
(1, 0).Value = rngFound.Offset _
(lngRow, lngColumn).Value
End If
End If
End If
End If
Set rngFound = .Cells.FindNext(rngFound)
Loop While rngFound.Address <> strFound
Else
MsgBox "Nothing!"
End If
End With
End Sub


Sample 2003

Sample 2007

21.03.2009

Formula - Comment!

You have formulas, which were provided with the formula editor? You would have these formulas gladly in the comment of a freely selectable cell (InputBox)? Or you would like a picture in the comment? Try the following. The files at the end of the article are Excelfiles of the version 2003 and 2007. The following code belonged in a "Module."


Du hast Formeln mit dem Formeleditor erstellt? Du möchtest diese Formeln in einer frei wählbaren Zelle (InputBox) in den Kommentar kopieren? Oder Du möchtest Bilder im Kommentar darstellen? Probiere den folgenden Code. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007. Der folgede Code gehört in ein "Modul."


Option Explicit
Dim strPath As String
Dim PicHeight As Long
Dim PicWidth As Long
Public Sub Ex_Pic()
Dim MyPicture As String
Dim MyChart As String
Dim MyObject As Shape
Dim strTMP As String
On Error GoTo Fin
strPath = Environ$("TEMP") & "\"
For Each MyObject In Sheet1.Shapes
Application.ScreenUpdating = True
If MyObject.DrawingObject.progID = "Equation.3" Then
MyPicture = MyObject.Name
With MyObject
PicHeight = .Height
PicWidth = .Width
.Height = .Height / 2
.Width = .Width / 2
End With
DoEvents
Application.ScreenUpdating = False
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet1"
Selection.Border.LineStyle = 0
MyChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
With Sheet1
With .Shapes(MyChart)
.Width = PicWidth
.Height = PicHeight
End With
With MyObject
.Height = PicHeight
.Width = PicWidth
End With
.Shapes(MyPicture).Copy
With ActiveChart
.ChartArea.Select
.Paste
End With
.ChartObjects(1).Chart.Export Filename:=strPath & _
"TMP.jpg", FilterName:="jpg"
.Shapes(MyChart).Cut
End With
strTMP = "$" & fncColumn(MyObject.TopLeftCell.Column + 3) & _
"$" & MyObject.TopLeftCell.Row
Call Pic_Comment(strTMP)
End If
Next MyObject
Fin:
Application.ScreenUpdating = True
If Err.Number <> 0 And Not Err.Number = 438 Then _
MsgBox "Keine Formel oder Zelle ausgewählt!"
End Sub
Private Sub Pic_Comment(strAddress As String)
Dim varTMP As Variant
Dim myCom As Object
Application.ScreenUpdating = True
Set varTMP = Application.InputBox("Auswahl", _
"Zelle", strAddress, , , , , 8)
Application.ScreenUpdating = False
With Sheet1
If Not .Cells(varTMP.Row, varTMP.Column).Comment Is Nothing Then _
.Cells(varTMP.Row, varTMP.Column).Comment.Delete
.Cells(varTMP.Row, varTMP.Column).AddComment
Set myCom = .Cells(varTMP.Row, varTMP.Column).Comment.Shape
With myCom
.Fill.UserPicture strPath & "TMP.jpg"
.Width = PicWidth
.Height = PicHeight
End With
End With
End Sub
Private Function fncColumn(lngTMP As Long) As String
fncColumn = Replace(Cells(1, lngTMP).Address(0, 0), "1", "")
End Function

The following code belonged In another Module:

Option Explicit
Dim strPath As String
Dim PicHeight As Long
Dim PicWidth As Long
Public Sub Ex_Pic_1()
Dim MyPicture As String
Dim MyChart As String
Dim MyObject As Shape
Dim strTMP As String
On Error GoTo Fin
strPath = Environ$("TEMP") & "\"
For Each MyObject In Sheet2.Shapes
Application.ScreenUpdating = True
If MyObject.Type = msoPicture Then
MyPicture = MyObject.Name
With MyObject
PicHeight = .Height
PicWidth = .Width
.Height = .Height / 2
.Width = .Width / 2
End With
DoEvents
Application.ScreenUpdating = False
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet2"
Selection.Border.LineStyle = 0
MyChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
With Sheet2
With .Shapes(MyChart)
.Width = PicWidth
.Height = PicHeight
End With
With MyObject
.Height = PicHeight
.Width = PicWidth
End With
.Shapes(MyPicture).Copy
With ActiveChart
.ChartArea.Select
.Paste
End With
.ChartObjects(1).Chart.Export Filename:=strPath & _
"TMP.jpg", FilterName:="jpg"
.Shapes(MyChart).Cut
End With
strTMP = "$" & fncColumn(MyObject.TopLeftCell.Column + 3) & _
"$" & MyObject.TopLeftCell.Row
Call Pic_Comment(strTMP)
End If
Next MyObject
Fin:
Application.ScreenUpdating = True
If Err.Number <> 0 And Not Err.Number = 438 Then _
MsgBox "Keine Formel oder Zelle ausgewählt!"
End Sub
Private Sub Pic_Comment(strAddress As String)
Dim varTMP As Variant
Dim myCom As Object
Application.ScreenUpdating = True
Set varTMP = Application.InputBox("Auswahl", _
"Zelle", strAddress, , , , , 8)
Application.ScreenUpdating = False
With Sheet2
If Not .Cells(varTMP.Row, varTMP.Column).Comment Is Nothing Then _
.Cells(varTMP.Row, varTMP.Column).Comment.Delete
.Cells(varTMP.Row, varTMP.Column).AddComment
Set myCom = .Cells(varTMP.Row, varTMP.Column).Comment.Shape
With myCom
.Fill.UserPicture strPath & "TMP.jpg"
.Width = PicWidth
.Height = PicHeight
End With
End With
End Sub
Private Function fncColumn(lngTMP As Long) As String
fncColumn = Replace(Cells(1, lngTMP).Address(0, 0), "1", "")
End Function


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