28.08.2008

Formula - Relatively - Absolutely!

With this code the formulas can be set relatively/absolutely - absolutely/relatively within a marked range in a worksheet. The code can be started over the combination of keys CTRL+F2. The files at the end of the article are Excelfiles of the version 2003 and 2007.


The following code belonged in "ThisWorkbook"



Option Explicit
Private Sub Workbook_Open()
Application.OnKey "^{F2}", "Module1.Relative_Absolute"
End Sub
Private Sub Workbook_Deactivate()
Application.OnKey "^{F2}"
End Sub

The following code belonged In "Module1"

Option Explicit
Public Sub Relative_Absolute()
Dim rngRange As Range
Dim rngCell As Range
On Error GoTo Relative_Absolute_Error
Set rngRange = Application.InputBox _
(Prompt:="Mark a range!", Type:=8)
Select Case InStr(ActiveCell.Formula, "$")
Case 0
For Each rngCell In rngRange
rngCell.Formula = Application.ConvertFormula _
(Formula:=rngCell.Formula, _
FromReferenceStyle:=xlA1, _
ToReferenceStyle:=xlA1, _
ToAbsolute:=xlAbsolute)
Next rngCell
Case Else
For Each rngCell In rngRange
rngCell.Formula = Application.ConvertFormula _
(Formula:=rngCell.Formula, _
FromReferenceStyle:=xlA1, _
ToReferenceStyle:=xlA1, _
ToAbsolute:=xlRelative)
Next rngCell
End Select
Set rngRange = Nothing
On Error GoTo 0
Exit Sub
Relative_Absolute_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
End Sub


Sample 2003

Sample 2007

24.08.2008

Character font - Small - Large!

Over a key (F11 more largely - F12 smaller) the character font within the marked range is changed, between sizes 6 and 120.


The following code belonged in "ThisWorkbook"


Option Explicit
Private Sub Workbook_Open()
Application.OnKey "{F11}", "Module1.Large"
Application.OnKey "{F12}", "Module1.Small"
End Sub
Private Sub Workbook_Deactivate()
Application.OnKey "{F11}"
Application.OnKey "{F12}"
End Sub

The following code belonged In "Module1"

Option Explicit
Public Sub Large()
Dim bytWriting As Byte
On Error GoTo Large_Error
With Selection.Font
bytWriting = .Size
bytWriting = bytWriting + 1
If bytWriting > 120 Then Exit Sub
.Size = bytWriting
End With
On Error GoTo 0
Exit Sub
Large_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
End Sub
Public Sub Small()
Dim bytWriting As Byte
On Error GoTo Small_Error
With Selection.Font
bytWriting = .Size
bytWriting = bytWriting - 1
If bytWriting < 6 Then Exit Sub
.Size = bytWriting
End With
On Error GoTo 0
Exit Sub
Small_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
End Sub


Sample 2003

Sample 2007

23.08.2008

Marked comments save!

All comments within a marked range are stored in a file in the temp directory. You can select between data attach or file overwrite. The file is opened at the end.

The following code belonged in "Module1"


Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Declare Function GetTempPath Lib "kernel32" Alias _
"GetTempPathA" (ByVal nBufferLength As Long, ByVal _
lpBuffer As String) As Long
Public Sub Comment_TXT()
Dim intFileNumber As Integer
Dim strComment As String
Dim rngRange As Range
Dim rngCell As Range
On Error GoTo Comment_TXT_Error
intFileNumber = FreeFile
Reset
Set rngRange = Application.InputBox("Mark a range!", , "$C$1:$L$9", Type:=8)
Select Case MsgBox _
("Comments attach (Click YES), or file overwrite (Click NO)?", _
vbYesNo Or vbQuestion Or vbDefaultButton1, "Comment")
Case vbYes
Open GetTempDir & "Comment.txt" For Append As #intFileNumber
Case vbNo
Open GetTempDir & "Comment.txt" For Output As #intFileNumber
End Select
For Each rngCell In rngRange
If Not rngCell.Comment Is Nothing Then
strComment = strComment & rngCell.Comment.Text & Chr(13) & Chr(10)
End If
Next rngCell
If strComment = "" Then Exit Sub
Print #intFileNumber, strComment
Close #intFileNumber
ShellExecute Application.hwnd, "Open", GetTempDir & _
"Comment.txt", vbNullString, vbNullString, vbNormalFocus
On Error GoTo 0
Exit Sub
Comment_TXT_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Reset
End Sub
Public Function GetTempDir() As String
Dim strPath As String
Dim lngCount As Long
Dim strTMP As String
strTMP = Space(255)
lngCount = GetTempPath(255, strTMP)
If lngCount > 0 Then
strPath = Left$(strTMP, lngCount)
If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
End If
GetTempDir = strPath
End Function


Sample 2003

Sample 2007

21.08.2008

Sheet - Name - Index - CodeName!


Often in forums the question is asked, how a worksheet in VBA can be addressed. There are different possibilities. With the name, the index or the code name. The name is in the brackets - the code name before the brackets. In my example thus name (One) and code name (Sheet1). The index goes from top to bottom. Pay attention to it whether it in a "For Next loop" "Sheets" or "Worksheets" use, because "Sheets" means all sheets inclusive chart sheets. If you work with the name of the worksheet you have problems, if the worksheet is renamed, and if you work with the index you have problems, if the worksheet is shifted. If you work with the CodeName of the worksheet, it can be renamed and shifted. The files at the end of the article are Excelfiles of the version 2003 and 2007.


The following code belonged in "Module1"


Option Explicit
'Problem, if the worksheet is renamed.
Public Sub Name_Sheet_Name()
Dim wksSheet As Worksheet
'The code in the out-commentated line supplies an error,
'if you have chart sheets in the file.
'For Each wksSheet In ThisWorkbook.Sheets
For Each wksSheet In ThisWorkbook.Worksheets
MsgBox "Worksheet name = " & wksSheet.Name
Next
End Sub
'Problem, if the worksheet is shifted.
Public Sub Name_Sheet_Index()
Dim wksSheet As Worksheet
For Each wksSheet In ThisWorkbook.Worksheets
MsgBox "Worksheet name = " & wksSheet.Name & _
vbCrLf & " Index = " & wksSheet.Index
Next
End Sub
'If you work with the CodeName of the worksheet,
'it can be renamed and shifted.
Public Sub Name_Sheet_CodeName()
Dim wksSheet As Worksheet
For Each wksSheet In ThisWorkbook.Worksheets
MsgBox "Worksheet name = " & wksSheet.Name & _
vbCrLf & " Index = " & wksSheet.Index & _
vbCrLf & "Worksheet CodeName = " & wksSheet.CodeName
Next
End Sub
Public Sub Sample_Name()
ThisWorkbook.Worksheets("One").Range("A1").Value = "Sample Name"
End Sub
Public Sub Sample_Index()
'ThisWorkbook.Worksheets(2).Range("A1").Value = "Sample Index"
'maybe chart sheets?
ThisWorkbook.Sheets(2).Range("A1").Value = "Sample Index"
End Sub
Public Sub Sample_CodeName()
Sheet1.Range("A1").Value = "Sample CodeName"
End Sub


Sample 2003

Sample 2007

15.08.2008

Insert file with hyperlink - multiple choice!

With double or right-click can files - also several - with hyperlink be inserted. The API function "GetCurrentDirectory" and "SetCurrentDirectory" prevents change over the current directory since as indicated in the VBA help "Application.FileDialog" always change the current directory. In the second code the file with path is written into the comment. The files at the end of the article are Excelfiles of the version 2003 and 2007.


The following code belonged In "Sheet1"

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
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
Dim strDirOld As String
Dim strFile As String
On Error GoTo Worksheet_Change_Error
strDirOld$ = String(255, 0)
Call GetCurrentDirectory(255, strDirOld$)
strDirOld$ = Left(strDirOld$, InStr(1, strDirOld$, vbNullChar) - 1)
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = "C:\"
.Title = "Selection of files"
.ButtonName = "Select..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strFile = .SelectedItems(1)
Else
MsgBox "No file was selected!"
Cancel = True
Exit Sub
End If
End With
Target.Value = Dir(strFile)
Target.Hyperlinks.Add Anchor:=Target, Address:=strFile
Target.Columns.AutoFit
Cancel = True
Call SetCurrentDirectory(strDirOld$)
On Error GoTo 0
Exit Sub
Worksheet_Change_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Call SetCurrentDirectory(strDirOld$)
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, _
Cancel As Boolean)
Dim strDirOld As String
Dim lngFiles As Long
On Error GoTo Worksheet_Change_Error
strDirOld$ = String(255, 0)
Call GetCurrentDirectory(255, strDirOld$)
strDirOld$ = Left(strDirOld$, InStr(1, strDirOld$, vbNullChar) - 1)
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = "C:\"
.Title = "Selection of files"
.ButtonName = "Select..."
.InitialView = msoFileDialogViewList
.AllowMultiSelect = True
If .Show = -1 Then
For lngFiles = 1 To .SelectedItems.Count
Target.Offset(lngFiles - 1, 0).Value = _
Dir(.SelectedItems(lngFiles))
Target.Offset(lngFiles - 1, 0).Hyperlinks.Add _
Anchor:=Target.Offset(lngFiles - 1, 0), _
Address:=.SelectedItems(lngFiles)
Next lngFiles
Else
MsgBox "No file was selected!"
Cancel = True
Exit Sub
End If
End With
Target.Columns.AutoFit
Cancel = True
Call SetCurrentDirectory(strDirOld$)
On Error GoTo 0
Exit Sub
Worksheet_Change_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Call SetCurrentDirectory(strDirOld$)
End Sub
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Application.CommandBars("Web").Visible = False
End Sub

The following code belonged In "Sheet2"

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
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
Dim strDirOld As String
Dim strFile As String
On Error GoTo Worksheet_Change_Error
strDirOld$ = String(255, 0)
Call GetCurrentDirectory(255, strDirOld$)
strDirOld$ = Left(strDirOld$, InStr(1, strDirOld$, vbNullChar) - 1)
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = "C:\"
.Title = "Selection of files"
.ButtonName = "Select..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strFile = .SelectedItems(1)
Else
MsgBox "No file was selected!"
Cancel = True
Exit Sub
End If
End With
Target.Value = Dir(strFile)
Target.AddComment.Text strFile
Target.Comment.Shape.TextFrame.AutoSize = True
Target.Hyperlinks.Add Anchor:=Target, Address:=strFile
Target.Columns.AutoFit
Cancel = True
Call SetCurrentDirectory(strDirOld$)
On Error GoTo 0
Exit Sub
Worksheet_Change_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Call SetCurrentDirectory(strDirOld$)
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, _
Cancel As Boolean)
Dim strDirOld As String
Dim lngFiles As Long
On Error GoTo Worksheet_Change_Error
strDirOld$ = String(255, 0)
Call GetCurrentDirectory(255, strDirOld$)
strDirOld$ = Left(strDirOld$, InStr(1, strDirOld$, vbNullChar) - 1)
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = "C:\"
.Title = "Selection of files"
.ButtonName = "Select..."
.InitialView = msoFileDialogViewList
.AllowMultiSelect = True
If .Show = -1 Then
For lngFiles = 1 To .SelectedItems.Count
Target.Offset(lngFiles - 1, 0).Value = Dir(.SelectedItems(lngFiles))
Target.Offset(lngFiles - 1, 0).AddComment.Text .SelectedItems(lngFiles)
Target.Offset(lngFiles - 1, 0).Comment.Shape.TextFrame.AutoSize = True
Target.Offset(lngFiles - 1, 0).Hyperlinks.Add _
Anchor:=Target.Offset(lngFiles - 1, 0), _
Address:=.SelectedItems(lngFiles)
Next lngFiles
Else
MsgBox "No file was selected!"
Cancel = True
Exit Sub
End If
End With
Target.Columns.AutoFit
Cancel = True
Call SetCurrentDirectory(strDirOld$)
On Error GoTo 0
Exit Sub
Worksheet_Change_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Call SetCurrentDirectory(strDirOld$)
End Sub
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Application.CommandBars("Web").Visible = False
End Sub


Sample 2003

Sample 2007

12.08.2008

Log a file - print, save, change, close!

Logs seems a popular topic to be. In the following example is logged open, close, save and print of a file. In addition changes on all worksheets are logged. However with multiple choice only up to a certain limit. Can be amended however in the code. If no limit is given here, perhaps then the macro runs itself to death - e.g. with mark a whole column, or evenly several columns. The files received depending upon event other names and are stored in determining temp directory. With "CTRL+ALT+F12" can ALL LOGS - which are stored in determined TEMP directory - be deleted. Possibly the file could with reaching a certain size or a certain number of lines to be deleted and/or a new file begin - that is your part. The files at the end of the article are Excelfiles of the version 2003 and 2007. The following code belonged in "ThisWorkbook".



Option Explicit
Dim varOldValue As Variant
Private Declare Function GetTempPath Lib "kernel32" Alias _
"GetTempPathA" (ByVal nBufferLength As Long, ByVal _
lpBuffer As String) As Long
Private Sub Workbook_Deactivate()
Application.OnKey "^%{F12}"
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, _
ByVal Target As Range)
Dim lngColumn As Long
Dim lngCount As Long
Dim lngRow As Long
lngRow = Target.Cells.Row
lngColumn = Target.Cells.Column
If Target.Cells.Count > 1 And Target.Cells.Count <= 20 Then
varOldValue = ""
For lngCount = 1 To Target.Cells.Count
If lngCount = Target.Cells.Count Then
varOldValue = varOldValue & _
Cells(lngRow, lngColumn).Value
lngRow = lngRow + 1
Else
varOldValue = varOldValue & _
Cells(lngRow, lngColumn).Value & vbLf
lngRow = lngRow + 1
End If
Next lngCount
Else
varOldValue = ActiveCell.Value
End If
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, _
ByVal Target As Range)
Dim intFreeFile As Integer
Dim strFileName As String
Dim strAddress As String
Dim strValue As String
Dim strPath As String
Dim strUser As String
Dim strDate As String
Dim strTime As String
Application.ScreenUpdating = False
strPath = GetTempDir & "WBook_Change.log"
intFreeFile = FreeFile
Reset
strUser = Environ("UserName")
strDate = Format(Now, "dd.mm.yyyy")
strTime = Format(Now, "hh:mm")
strFileName = ThisWorkbook.FullName
strAddress = Target.Address(False, False)
strValue = Target.Resize(1, 1).Text
Open strPath For Append As #1
Print #1, strUser & vbTab & strDate & vbTab & strTime
Print #1, strFileName
Print #1, Sh.Name
Print #1, strAddress
If strValue = "" Then
Print #1, "Eingegebner Wert" & vbTab & "0"
Else
Print #1, "Eingegebner Wert" & vbTab & strValue
End If
If varOldValue = "" Then
Print #1, "Alter Wert" & vbTab & vbTab & "0"
Else
Print #1, "Alter Wert" & vbTab & vbTab & varOldValue
End If
Print #1, "-----------------------------"
Close #1
Application.ScreenUpdating = True
End Sub
Private Sub Workbook_Open()
Dim strPath As String
Application.OnKey "^%{F12}", "DieseArbeitsmappe.Loeschen"
strPath = GetTempDir & "WBook_Open.log"
Call LOG(strPath)
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim strPath As String
strPath = GetTempDir & "WBook_Close.log"
Call LOG(strPath)
End Sub
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim strPath As String
strPath = GetTempDir & "WBook_Print.log"
Call LOG(strPath)
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, _
Cancel As Boolean)
Dim strPath As String
strPath = GetTempDir & "WBook_Save.log"
Call LOG(strPath)
End Sub
Private Sub LOG(ByVal strPathDatei As String)
Dim intFreeFile As Integer
Dim strFileName As String
Dim strPath As String
Dim strUser As String
Dim strDate As String
Dim strTime As String
strPath = strPathDatei
intFreeFile = FreeFile
Reset
strUser = Environ("UserName")
strDate = Format(Now, "dd.mm.yyyy")
strTime = Format(Now, "hh:mm")
strFileName = ThisWorkbook.FullName
Open strPath For Append As #1
Print #1, strUser & vbTab & strDate & vbTab & strTime
Print #1, strFileName
Print #1, "-----------------------------"
Close #1
End Sub
Private Sub Loeschen()
On Error Resume Next
Kill (GetTempDir & "WBook_*.log")
On Error GoTo 0
End Sub
Private Function GetTempDir() As String
Dim strTemp As String
Dim strPath As String
Dim lngCount As Long
strTemp = Space(255)
lngCount = GetTempPath(255, strTemp)
If lngCount > 0 Then
strPath = Left$(strTemp, lngCount)
If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
End If
GetTempDir = strPath
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 ...