15.11.2008

Cell - Read - Closed Files!

From closed Workbooks certain cells are selected and summed up. The cells which can be selected are indicated in Sheet2 in column A. Some lines in the code must be adapted. These are characterized. In the ZIP file are example files. It functions immediately, if the file with the code is in the same folder as the files with the cells which must be read in. Subfolders are considered. The files at the end of the article are Excelfiles of the version 2003 and 2007.


The following code belonged In "Module1"

Option Explicit
Option Private Module
Const strSheet As String = "Sheet1" 'adapt
Public Sub Files_Read()
Dim stCalc As XlCalculation
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
stCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
strDir = ThisWorkbook.Path 'adapt
Set objDir = objFSO.GetFolder(strDir)
dirInfo objDir, "*.xls"
Fin:
With Application
.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)
Dim objWorkbook As Workbook
Dim strFormula As String
Dim varRange As Variant
Dim varTMP As Variant
Dim intTMP As Integer
For Each varTMP In objCurrentDir.Files
If varTMP.Name Like strName And varTMP.Name <> _
ThisWorkbook.Name Then
With Sheet2 'adapt
varRange = .Range(.Cells(1, 1), .Cells _
(.Rows.Count, 1).End(xlUp).Rows)
strFormula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev _
(varTMP.Path, "\") + 1) & "]" & strSheet & "'!"
For intTMP = 1 To Ubound(varRange)
.Range("B" & intTMP).Formula = _
strFormula & varRange(intTMP, 1)
Sheet1.Range(varRange(intTMP, 1)).Value = _
Sheet1.Range(varRange(intTMP, 1)).Value + _
.Range("B" & intTMP).Value
Next intTMP
End With
End If
Next
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName
Next varTMP
Set objWorkbook = Nothing
End Sub


Sample ZIP - 2007 and 2003

02.11.2008

Pictures centers!

Cliparts in one worksheet, or in all worksheets are centered vertically and horizontal in the cell. The pictures can be aligned also again left above. The individual examples differed only in the kind, how the worksheet is addressed. The files at the end of the article are Excelfiles of the version 2003 and 2007.


The following code belonged In "Module1"

Option Explicit
Public Sub Picture_Center_Index()
Dim shpPicture As Shape
With ThisWorkbook.Worksheets(1)
For Each shpPicture In .Shapes
If shpPicture.Type = msoPicture Then
shpPicture.Left = shpPicture.Left + _
(shpPicture.TopLeftCell.Width - _
shpPicture.Width) / 2
shpPicture.Top = shpPicture.Top + _
(shpPicture.TopLeftCell.Height - _
shpPicture.Height) / 2
End If
Next shpPicture
End With
End Sub
Public Sub Picture_Center_Name()
Dim shpPicture As Shape
With ThisWorkbook.Worksheets("Sheet1")
For Each shpPicture In .Shapes
If shpPicture.Type = msoPicture Then
shpPicture.Left = shpPicture.Left + _
(shpPicture.TopLeftCell.Width - _
shpPicture.Width) / 2
shpPicture.Top = shpPicture.Top + _
(shpPicture.TopLeftCell.Height - _
shpPicture.Height) / 2
End If
Next shpPicture
End With
End Sub
Public Sub Picture_Center_CodeName()
Dim shpPicture As Shape
With Sheet1
For Each shpPicture In .Shapes
If shpPicture.Type = msoPicture Then
shpPicture.Left = shpPicture.Left + _
(shpPicture.TopLeftCell.Width - _
shpPicture.Width) / 2
shpPicture.Top = shpPicture.Top + _
(shpPicture.TopLeftCell.Height - _
shpPicture.Height) / 2
End If
Next shpPicture
End With
End Sub
Public Sub Picture_Center_All_Worksheet()
Dim wksSheet As Worksheet
Dim shpPicture As Shape
For Each wksSheet In ThisWorkbook.Worksheets
With wksSheet
For Each shpPicture In .Shapes
If shpPicture.Type = msoPicture Then
shpPicture.Left = shpPicture.Left + _
(shpPicture.TopLeftCell.Width - _
shpPicture.Width) / 2
shpPicture.Top = shpPicture.Top + _
(shpPicture.TopLeftCell.Height - _
shpPicture.Height) / 2
End If
Next shpPicture
End With
Next wksSheet
End Sub
Public Sub Picture_Reset()
Dim wksSheet As Worksheet
Dim shpPicture As Shape
For Each wksSheet In ThisWorkbook.Worksheets
With wksSheet
For Each shpPicture In .Shapes
If shpPicture.Type = msoPicture Then
shpPicture.Left = _
shpPicture.TopLeftCell.Left
shpPicture.Top = _
shpPicture.TopLeftCell.Top
End If
Next shpPicture
End With
Next wksSheet
End Sub


Sample 2003

Sample 2007

01.11.2008

Check Boxes from Form Controls!

Information about check boxes from form controls. You can check, reset, move, create and other things. The "Create Button" is to demonstrates that also. e.g. for a COMMANDBUTTON (ActiveX Controls) in the worksheet the code to set or reset the hook has to be changed. The files at the end of the article are Excelfiles of the version 2003 and 2007.


The following code belonged in "Module1"


Option Explicit
Sub CHECK_Formular_CheckBox()
Dim shpBox As Shape
For Each shpBox In ActiveSheet.Shapes
If shpBox.Type <> msoOLEControlObject Then
If shpBox.FormControlType = xlCheckBox Then
shpBox.ControlFormat.Value = 1
End If
End If
Next
End Sub
Sub Reset_Formular_CheckBox()
Dim shpBox As Shape
For Each shpBox In ActiveSheet.Shapes
If shpBox.AlternativeText Like "Box*" Then
shpBox.ControlFormat.Value = False
End If
Next
End Sub
Sub Reset_Formular_CheckBox_1()
Dim shpBox As Shape
For Each shpBox In ActiveSheet.Shapes
If shpBox.FormControlType = xlCheckBox Then
shpBox.ControlFormat.Value = False
End If
Next
End Sub
Sub Reset_Formular_CheckBox_2()
Dim shpBox As Shape
For Each shpBox In ActiveSheet.Shapes
If shpBox.FormControlType = 1 Then
shpBox.ControlFormat.Value = 0
End If
Next
End Sub
Sub Create_Button()
If Sheet1.OLEObjects.Count >= 1 Then Exit Sub
With Sheet1.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
Left:=435, Top:=225, Width:=60, Height:=30)
.Name = "CButton"
.Object.Caption = "Test"
End With
End Sub
Sub Delete_Button()
On Error Resume Next
Sheet1.Shapes("CButton").Delete
End Sub
Sub Reset_Formular_CheckBox_3()
Dim shpBox As Shape
For Each shpBox In ActiveSheet.Shapes
If shpBox.Type <> msoOLEControlObject Then
If shpBox.FormControlType = xlCheckBox Then
shpBox.ControlFormat.Value = False
End If
End If
Next
End Sub
Sub Step_Right()
Dim shpBox As Shape
For Each shpBox In ActiveSheet.Shapes
If shpBox.Type <> msoOLEControlObject Then
If shpBox.FormControlType = xlCheckBox Then
shpBox.Left = shpBox.Left + 50
End If
End If
Next
End Sub
Sub Step_Left()
Dim shpBox As Shape
For Each shpBox In ActiveSheet.Shapes
If shpBox.Type <> msoOLEControlObject Then
If shpBox.FormControlType = xlCheckBox Then
shpBox.Left = shpBox.Left - 50
End If
End If
Next
End Sub
Sub CheckBox_Linked_Cell()
Dim shpBox As Shape
For Each shpBox In ActiveSheet.Shapes
If Left(shpBox.Name, 5) = "Check" Then
shpBox.ControlFormat.LinkedCell = shpBox.TopLeftCell.Offset(0, 1).Address
Debug.Print shpBox.ControlFormat.LinkedCell
End If
Next
End Sub
Sub CheckBox_Create()
Dim objBox As Object
Set objBox = ActiveSheet.CheckBoxes.Add(0, 0, 0, 0)
With objBox
.Left = Cells(22, 3).Left
.Top = Cells(22, 3).Top
.Height = 17.25
.Width = 96
.Caption = "New 11"
End With
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 ...