personal.xls

**drums4monty** · 02-23-2009, 01:09 AM

Hi All

I am trying to get the personal.xls to work on my notebook, it runs Xp and I have MS Office XP. I have had no problems in the past on other machines but this time I do not seem to be able to save to personal.xls. I have tried to create it following the steps from the MS Site but all I get is an error message saying 'File Cannot Be Read'. I create the new Text Document and follow the instructions but it just seem to be a Text Document. I must be soing something wrong, is there any help out there?

Alan

**drums4monty** · 02-23-2009, 01:37 AM

I have copied personal.xls from my old machine to the new one and when I run the macros I get this error .HorizontalAligment = xlLeft and I would assume I would get others, the macros work fine on the old machine(s). Any Ideas?

Alan

**Bob Phillips** · 02-23-2009, 01:43 AM

Show the full code so as to get the context.

**drums4monty** · 02-23-2009, 02:19 AM

Here you go . . . . (in fact you may have wrote this for me)

[VBA]
Sub FormatStockSheetOct08()
'
' Unmerge Macro
' Macro recorded 20/11/2006 by Alan
'
'
Sheets("Uniforms").Select
Range("A1:F1").Select
Range("A7:F7").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A22:F22").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A38:F38").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
ActiveWindow.SmallScroll Down:=63
Range("A65:F65").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A97:F97").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A109:F109").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A127:F127").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
ActiveWindow.SmallScroll Down:=-75
Range("A7").Select
Call ItemShow
End Sub
Sub ItemShow()
'
' ItemShowUniform Macro
' Macro recorded 18/11/2006 by Alan
' Puts a white 1 in Item Cells in Col C
'
Sheets("Uniforms").Select
Range("A1:F1").Select
Range("C7").Select
ActiveCell.FormulaR1C1 = "1"
Range("C7").Select
Selection.Font.ColorIndex = 2
Selection.Copy
Range("C22").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Range("C38").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=36
Range("C65").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=39
Range("C97").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Range("C109").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Range("C127").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=9
Range("A7").Select
Call colour
End Sub
Sub colour()
'
' colour Macro
' Macro recorded 29/11/2006 by abeaumont
'
'
Range("A9:F14").Select
With Selection.Interior
.ColorIndex = 40
.Pattern = xlSolid
End With
Range("A17:F20").Select
With Selection.Interior
.ColorIndex = 34
.Pattern = xlSolid
End With
Range("A24:F29").Select
With Selection.Interior
.ColorIndex = 40
.Pattern = xlSolid
End With
ActiveWindow.SmallScroll Down:=12
Range("A31:F34").Select
With Selection.Interior
.ColorIndex = 34
.Pattern = xlSolid
End With
Range("A40:F45").Select
With Selection.Interior
.ColorIndex = 40
.Pattern = xlSolid
End With
ActiveWindow.SmallScroll Down:=21
Range("A47:F52").Select
With Selection.Interior
.ColorIndex = 40
.Pattern = xlSolid
End With
Range("A54:F58").Select
With Selection.Interior
.ColorIndex = 34
.Pattern = xlSolid
End With
Range("A60:F63").Select
With Selection.Interior
.ColorIndex = 34
.Pattern = xlSolid
End With
ActiveWindow.SmallScroll Down:=24
Range("A67:F72").Select
With Selection.Interior
.ColorIndex = 40
.Pattern = xlSolid
End With
Range("A74:F79").Select
With Selection.Interior
.ColorIndex = 34
.Pattern = xlSolid
End With
Range("A87:F90").Select
With Selection.Interior
.ColorIndex = 40
.Pattern = xlSolid
End With
ActiveWindow.SmallScroll Down:=21
Range("A92:F95").Select
With Selection.Interior
.ColorIndex = 34
.Pattern = xlSolid
End With
Range("A99:F102").Select
With Selection.Interior
.ColorIndex = 40
.Pattern = xlSolid
End With
Range("A104:F107").Select
With Selection.Interior
.ColorIndex = 34
.Pattern = xlSolid
End With
Range("A117:F120").Select
With Selection.Interior
.ColorIndex = 40
.Pattern = xlSolid
End With
ActiveWindow.SmallScroll Down:=21
Range("A122:F125").Select
With Selection.Interior
.ColorIndex = 34
.Pattern = xlSolid
End With
Range("A129:F134").Select
With Selection.Interior
.ColorIndex = 40
.Pattern = xlSolid
End With
'Range("A131:F136").Select
'With Selection.Interior
' .ColorIndex = 40
' .Pattern = xlSolid
'End With
Range("A7").Select
Call removeblanks
End Sub
Sub removeblanks()
'
' Deletes all rows which is either blank or has a 0 (xero) in it
Dim rng As Range
Dim myCell
Dim i
Set rng = Range("C9:C134")
With rng
Set c = .Find(0, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
Do
c.ClearContents
Set c = .FindNext(c)
Loop While Not c Is Nothing
End If
rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
Range("A7").Select
Call Workbook_BeforePrint
End Sub
Sub Workbook_BeforePrint()
'assumes you're printing the active sheet
Dim sName As String
If [B3] = Empty Then
' Cancel = True
[B3].Activate
sName = InputBox("The twits have not entered their club name:")
[B3] = sName
End If
Sheets("Stationery").Select
If [B3] = Empty Then
' Cancel = True
[B3].Activate
sName = InputBox("The twits have not entered their club name:")
[B3] = sName
End If
Sheets("Retail").Select
If [B3] = Empty Then
' Cancel = True
[B3].Activate
sName = InputBox("The twits have not entered their club name:")
[B3] = sName
End If
Sheets("Name Badges").Select
If [B3] = Empty Then
' Cancel = True
[B3].Activate
sName = InputBox("The twits have not entered their club name:")
[B3] = sName
End If
Range("A6").Select
Call FormatAll
End Sub

Sub FormatAll()
' FormatAll Macro
' Macro recorded 18/11/2006 by Alan
' Moves onto Retail Sheet
Dim ActiveWB As Workbook

Set ActiveWB = ActiveWorkbook
If ActiveWB.Sheets("Stationery").Range("E50") >= 1 Then
MsgBox "Purchase Order Pads Required", , "Bannatyne Fitness Ltd."
Workbooks.Open Filename:="C:\Documents and Settings\abeaumont\Desktop\Stock Stuff\All Purchase Order Pads.xls"
Sheets("Detailed Movement").Select
End If
ActiveWB.Activate
Range("A6").Select
Sheets("Retail").Select
Call FormatSheetRetailOct08
'Application.Run "PERSONAL.XLS!FormatSheetRetailOct08"

End Sub
[/VBA]

**Bob Phillips** · 02-23-2009, 03:01 AM

No, that is not my code.

I cannot see anything obvious, but the code can be simplified ... a lot.

See if this works okay

[vba]

Option Explicit

Sub FormatStockSheetOct08()
'
' Unmerge Macro
' Macro recorded 20/11/2006 by Alan
'
'
With Sheets("Uniforms").Range("A7:F7,A22:F22,A38:F38,A65:F65,A97:F97,A109:F109,A 127:F127")
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A7").Select
Call ItemShow
End Sub

Sub ItemShow()
'
' ItemShowUniform Macro
' Macro recorded 18/11/2006 by Alan
' Puts a white 1 in Item Cells in Col C
'
Sheets("Uniforms").Select
Range("A1:F1").Select
With Range("C7")
.Value = "1"
.Font.ColorIndex = 2
.Copy Range("C22")
.Copy Range("C38")
.Copy Range("C65")
.Copy Range("C97")
.Copy Range("C109")
.Copy Range("C127")
Call colour
End With
End Sub

Sub colour()
'
' colour Macro
' Macro recorded 29/11/2006 by abeaumont
'
'
With Range("A9:F14,A24:F29,A40:F45,A47:F52,A67:F72,A87:F90,A99:F102,A117:F120,A1 29:F134").Interior
.ColorIndex = 40
.Pattern = xlSolid
End With

With Range("A17:F20,A31:F34,A54:F58,A60:F63,A74:F79,A92:F95,A104:F107,A122:F125" ).Interior
.ColorIndex = 34
.Pattern = xlSolid
End With

Range("A7").Select
Call removeblanks
End Sub

Sub removeblanks()
'
' Deletes all rows which is either blank or has a 0 (xero) in it
Dim rng As Range
Dim myCell
Dim i
Set rng = Range("C9:C134")
With rng
Set c = .Find(0, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
Do
c.ClearContents
Set c = .FindNext(c)
Loop While Not c Is Nothing
End If
rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
Range("A7").Select
Call Workbook_BeforePrint
End Sub

Sub Workbook_BeforePrint()
'assumes you're printing the active sheet
Dim sName As String
With Range("B3")

If .Value = Empty Then
' Cancel = True
sName = InputBox("The twits have not entered their club name:")
.Value = sName
End If
End With

With Sheets("Stationery").Range("B3")

If .Value = Empty Then
' Cancel = True
sName = InputBox("The twits have not entered their club name:")
.Value = sName
End If
End With

With Sheets("Retail").Range("B3")

If .Value = Empty Then
' Cancel = True
sName = InputBox("The twits have not entered their club name:")
.Value = sName
End If
End With

With Sheets("Name Badges").Range("B3")

If .Value = Empty Then
' Cancel = True
sName = InputBox("The twits have not entered their club name:")
.Value = sName
End If
End With

Range("A6").Select
Call FormatAll
End Sub

Sub FormatAll()
' FormatAll Macro
' Macro recorded 18/11/2006 by Alan
' Moves onto Retail Sheet
Dim ActiveWB As Workbook

Set ActiveWB = ActiveWorkbook
If ActiveWB.Sheets("Stationery").Range("E50") >= 1 Then

MsgBox "Purchase Order Pads Required", , "Bannatyne Fitness Ltd."
Workbooks.Open Filename:="C:\Documents and Settings\abeaumont\Desktop\Stock Stuff\All Purchase Order Pads.xls"
Sheets("Detailed Movement").Select
End If
ActiveWB.Activate
Range("A6").Select
Sheets("Retail").Select
Call FormatSheetRetailOct08
'Application.Run "PERSONAL.XLS!FormatSheetRetailOct08"
End Sub
[/vba]

**drums4monty** · 02-23-2009, 09:02 AM

Thanks xld. Ive run it but still get the error message which is 'Unable to set the HorizontalAligment property of the Range class'. I get this error on both machines now.

**Bob Phillips** · 02-23-2009, 09:33 AM

Is the worksheet protected?

**drums4monty** · 02-23-2009, 10:03 AM

Yes it is, I have actually got a macro that unprotects it before the other macros run, which now they do. I dont know how that macro went missing but as soon as you mentioned protection it all made sense. I hope that I have not wasted your time on such a stupid error.

Alan