'Ruler for Excel(inch) 'Insert a new module, copy the following code and paste to the module. 'Run the macro "MakeRuler_inch". Sub MakeRuler_inch() 'Define the size of a new ruler. Const Ruler_Width As Double = 6 'Width 6 inch Const Ruler_Height As Double = 5 'Height 5 inch 'The setting size on the screen and the actual size on the printer. Const Screen_Width As Double = 6 Const Screen_Height As Double = 5 Const Printer_Width As Double = 6 Const Printer_Height As Double = 5 Dim i As Long Dim l As Double Dim x As Long Dim y As Long Dim ws As Worksheet Dim a(0 To 15) As Double Dim x2 As Double Dim y2 As Double x = Ruler_Width * 16 y = Ruler_Height * 16 a(0) = 3.6: a(1) = 1: a(2) = 2: a(3) = 1: a(4) = 2: a(5) = 1: a(6) = 2: a(7) = 1 a(8) = 3: a(9) = 1: a(10) = 2: a(11) = 1: a(12) = 2: a(13) = 1: a(14) = 2: a(15) = 1 Application.ScreenUpdating = False Set ws = ActiveSheet Worksheets.Add ActiveSheet.Move ActiveSheet.Lines.Add 0, 0, 3 * x, 0 For i = 1 To x l = a(i Mod 16) ActiveSheet.Lines.Add 3 * i, 0, 3 * i, 3 * l Next ActiveSheet.Lines.Add 0, 0, 0, 3 * y For i = 1 To y l = a(i Mod 16) ActiveSheet.Lines.Add 0, 3 * i, 3 * l, 3 * i Next ActiveSheet.Lines.Border.ColorIndex = 55 For i = 16 To x - 1 Step 16 With ActiveSheet.TextBoxes.Add(3 * i - 9, 3 * 3.6, 18, 12) .Text = Format(i \ 16, "!@@") End With Next For i = 16 To y - 1 Step 16 With ActiveSheet.TextBoxes.Add(3 * 3.6, 3 * i - 9, 12, 18) .Orientation = xlDownward .Text = Format(i \ 16, "!@@") End With Next With ActiveSheet.TextBoxes .Font.Size = 9 .Font.ColorIndex = 55 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Border.ColorIndex = xlNone .Interior.ColorIndex = xlNone End With With ActiveSheet.DrawingObjects.Group .Placement = xlFreeFloating .Width = Application.InchesToPoints(x / 16) .Height = Application.InchesToPoints(y / 16) .CopyPicture xlScreen, xlPicture ActiveSheet.Paste x2 = (Selection.Width - .Width) / 3 y2 = (Selection.Height - .Height) / 3 Selection.Delete .CopyPicture xlPrinter, xlPicture ActiveSheet.Paste .Width = .Width * .Width / (Selection.Width - x2 * 2) * Screen_Width / Printer_Width .Height = .Height * .Height / (Selection.Height - y2 * 2) * Screen_Height / Printer_Height Selection.Delete If Val(Application.Version) >= 9 Then .Copy ActiveSheet.PasteSpecial 'Format:="Picture (PNG)" With Selection.ShapeRange.PictureFormat .CropLeft = x2 .CropTop = y2 .CropRight = x2 .CropBottom = y2 End With Selection.Copy ws.Activate ws.PasteSpecial 'Format:="Picture (PNG)" Selection.Placement = xlFreeFloating .Parent.Parent.Close False End If End With Application.ScreenUpdating = True End Sub 'Ruler for Excel(Centimeter) Sub MakeRuler_cm() 'Define the size of a new ruler. Const Ruler_Width As Double = 16 'Width 16 cm Const Ruler_Height As Double = 14 'Height 14 cm 'The setting size on the screen and the actual size on the printer. Const Screen_Width As Double = 16 Const Screen_Height As Double = 14 Const Printer_Width As Double = 16 Const Printer_Height As Double = 14 Dim i As Long Dim l As Long Dim x As Long Dim y As Long Dim ws As Worksheet Dim x2 As Double Dim y2 As Double x = Ruler_Width * 10 y = Ruler_Height * 10 Application.ScreenUpdating = False Set ws = ActiveSheet Worksheets.Add ActiveSheet.Move ActiveSheet.Lines.Add 0, 0, 3 * x, 0 For i = 1 To x If i Mod 10 = 0 Then l = 5 Else: If i Mod 5 = 0 Then l = 4 Else l = 3 ActiveSheet.Lines.Add 3 * i, 0, 3 * i, 3 * l Next ActiveSheet.Lines.Add 0, 0, 0, 3 * y For i = 1 To y If i Mod 10 = 0 Then l = 5 Else: If i Mod 5 = 0 Then l = 4 Else l = 3 ActiveSheet.Lines.Add 0, 3 * i, 3 * l, 3 * i Next ActiveSheet.Lines.Border.ColorIndex = 55 For i = 10 To x - 1 Step 10 With ActiveSheet.TextBoxes.Add(3 * i - 9, 3 * 5, 18, 12) .Text = Format(i \ 10, "!@@") End With Next For i = 10 To y - 1 Step 10 With ActiveSheet.TextBoxes.Add(3 * 5, 3 * i - 9, 12, 18) .Orientation = xlDownward .Text = Format(i \ 10, "!@@") End With Next With ActiveSheet.TextBoxes .Font.Size = 9 .Font.ColorIndex = 55 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Border.ColorIndex = xlNone .Interior.ColorIndex = xlNone End With With ActiveSheet.DrawingObjects.Group .Placement = xlFreeFloating .Width = Application.CentimetersToPoints(x / 10) .Height = Application.CentimetersToPoints(y / 10) .CopyPicture xlScreen, xlPicture ActiveSheet.Paste x2 = (Selection.Width - .Width) / 3 y2 = (Selection.Height - .Height) / 3 Selection.Delete .CopyPicture xlPrinter, xlPicture ActiveSheet.Paste .Width = .Width * .Width / (Selection.Width - x2 * 2) * Screen_Width / Printer_Width .Height = .Height * .Height / (Selection.Height - y2 * 2) * Screen_Height / Printer_Height Selection.Delete If Val(Application.Version) >= 9 Then .Copy ActiveSheet.PasteSpecial 'Format:="Picture (PNG)" With Selection.ShapeRange.PictureFormat .CropLeft = x2 .CropTop = y2 .CropRight = x2 .CropBottom = y2 End With Selection.Copy ws.Activate ws.PasteSpecial 'Format:="Picture (PNG)" Selection.Placement = xlFreeFloating .Parent.Parent.Close False End If End With Application.ScreenUpdating = True End Sub