1
\$\begingroup\$

I have lots of workbooks on a given format. The workbooks explain a series of certain objects. I don't want to reveal exactly what this is, so I'll refer to it as just an "Item". I need to do the following:

Note: I have to open each files manually, since I need to check a comment in one of the cells manually.

  • Read and store the last line of a merged cell (starting at A63)
  • Update the following, if the cell A58 is empty:

    • Mark that the Item is not close to road, unless it's already marked as being close to a road.

    • Delete the content of O7, if Q3-Q5 are empty

    • Update the title field. This is the same merged cell starting at A63 as before. The first line should be bold. The last line should be the same as the previous title (stored in the beginning).
    • Enter some values
    • Retrieve the name of the workbook, and insert the name in field O75
    • Find east and north coordinates from the workbook "Coordinate_document.xlsx". The values are in sheet 2.
    • I use a for loop to match the last line of the title, with the first column in the coordinate workbook.
    • The coordinates are stored in the active workbook, on the formats given in the script.
  • The workbook is saved in the end. It's not closed, since I need to do some manual checks too. I do want to save it, since I rarely change something after the macro finishes.

Sub updateCells()

    Dim wbkSketchBook As Workbook
    Dim wksSketchSheet As Worksheet

    Set wbkSketchBook = ActiveWorkbook
    Set wksSketchSheet = wbkSketchBook.ActiveSheet

    ' If the title starts with "L", then the number of characters that must be trimmed 
    ' away on the left side is 49. Otherwise it's 40.
    ' I do this in the beginning, since I need sMast throughout the script.
    Dim sTitle As String
    Dim sMast As String
    sTitle = wksSketchSheet.Range("A63").Value

    ' The first letter is stored, to be used while in debugging mode. 
    sFirstLetter = Left(sTitle, 1)
    If sFirstLetter = "L" Then
        sMast = Right(sTitle, Len(sTitle) - 49)
    Else
        sMast = Right(sTitle, Len(sTitle) - 40)
    End If

    ' Don't run the following part of the script if there's already a value in cell AB58.
    If IsEmpty(Range("AB58").Value) = True Then

        ' Place an X in cell AB53 (not close to road), only if cell X53 (close to road) and
        ' cell AB53 (explanation of why X53 is checked) are empty.
        ' If 'X53' is non-empty, and AB53 is empty, then display a message box saying this
        ' must be verified.
        If IsEmpty(Range("X53").Value) = True Then
            If IsEmpty(Range("X54").Value) = True Then
                Range("AB53").Value = "X"
            Else
                MsgBox ("Close or not? Fix after macro is finished!")
            End If
        End If

        ' Check if there's a comment in U3. If not, then display a message box asking for
        ' verification that this is correct.
        If IsEmpty(Range("U3").Value) = True Then
            MsgBox ("No comment! Check after macro is finished!")
        End If

        ' AI71, Executing should be "ABCD":
        Range("AI71").Value = "ABCD"

        ' Check if all Q3-Q5 are empty. If so, delete the content of O7.
        ' O7 is only relevant if one of the 
        If IsEmpty(Range("Q3").Value) = True Then
            If IsEmpty(Range("Q4").Value) = True Then
                If IsEmpty(Range("Q5").Value) = True Then
                    Range("O7").Value = ""
                End If
            End If
        End If

        ' Change the title. This is a merged cell, A63:AH67. The format is over three lines.
        ' The last line is the string sMast, while the others are fixed.
        ' The first line should be bold.
        Range("A63:AH67").Select
        ActiveCell.FormulaR1C1 = 
        '    "L1234.1 ABCD - Efghijklmn 123 oP" & Chr(10) & "Qrstuvwx sketch" & Chr(10) & sMast
        With ActiveCell.Characters(Start:=1, Length:=33).Font
            .Name = "Arial"
            .FontStyle = "Halvfet"
            .Size = 12
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .ThemeFont = xlThemeFontNone
        End With
        With ActiveCell.Characters(Start:=34, Length:=(Len(sTitle) - 22)).Font
            .Name = "Arial"
            .FontStyle = "Normal"
            .Size = 11
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .ColorIndex = xlAutomatic
            .TintAndShade = 0
            .ThemeFont = xlThemeFontNone
        End With

        ' The classification must be updated (merged cell):
        Range("A73:N73").Value = "Classification value"

        ' This should be "N/A" (merged cell). 
        Range("AB58:AF58").Value = "N/A"

        ' Update document number in O75. It should have the same name as the file,
        ' with .xlsx removed
        Dim sDocumentNumber As String

        ' I can't use a fixed string, since I open many workbooks, and run the macro on each one.
        ' The macro is executed immediately after opening the workbook.
        sDocumentNumber = ActiveWorkbook.Name
        sDocumentNumber = Left(sDocumentNumber, Len(sDocumentNumber) - 5)
        Range("O75").Value = sDocumentNumber

    End If
    ' The previous part was only executed if there was no value in AB58.
    ' The following should be executed, regardless of what that cell contains.
    ' Coordinates:
    Dim sNorth As String
    Dim sEast As String

    Dim sCoordinateBook As Worksheet
    Set sCoordinateBook = Workbooks("Coordinate_document.xlsx").Worksheets(2)


    Dim sMastenummer As String
    sMastenummer = Right(sMast, Len(sMast) - 3)
    Dim sValueEachIteration As String

    Dim iterator As Long
    Dim idx As Long
    For iterator = 7 To 140
        ' The value each iteration is store, to be used while in debugging mode. 
        sValueEachIteration = sCoordinateBook.Cells(iterator, 1).Value

        ' If the value in that row in the Coorinate Book is equal to sMastenummer, then
        ' Then store the iterator.
        If sValueEachIteration = sMastenummer Then
            idx = iterator
        End If
    Next iterator

    ' Store the coordinates.
    sNorth = sCoordinateBook.Cells(idx, 2).Value
    sEast = sCoordinateBook.Cells(idx, 3).Value

    ' The ActiveSheet should still be the first workbook that was opened. The worksheet
    ' name should be "Drawing". If that's not the case, then something is wrong.
    If ActiveSheet.Name = "Drawing" Then
        Cells(54, 17).Value = sNorth
        Cells(54, 17).NumberFormat = "0000000.000"
        Cells(55, 17).Value = sEast
        Cells(55, 17).NumberFormat = "000000.000"
        ActiveWorkbook.Save
    Else
        MsgBox("The wrong workbook is active!")     
    End If

    ' The Workbook is saved if the coordinates are inserted properly. It is not closed,
    ' because I need to verify the values of some cells manually.       
End Sub

So, any comments?

\$\endgroup\$
1
\$\begingroup\$

You have a lot of unqualified Range() calls in your code: your procedure would be more robust of you qualify all those calls with a worksheet object.

It's maybe just a preference, but I'd prefer to write this:

' The first letter is stored, to be used while in debugging mode. 
sFirstLetter = Left(sTitle, 1)
If sFirstLetter = "L" Then
    sMast = Right(sTitle, Len(sTitle) - 49)
Else
    sMast = Right(sTitle, Len(sTitle) - 40)
End If

instead as this:

' The first letter is stored, to be used while in debugging mode. 
sFirstLetter = Left(sTitle, 1)
sMast = Right(sTitle, Len(sTitle) - IIf(sFirstLetter = "L", 49, 40))

since you end up with less repeated code.

This code:

Range("A63:AH67").Select
ActiveCell.FormulaR1C1 = "..."

is better written as:

 Range("A63:AH67").Value = "..."

You almost never need to select/activate anything when working with VBA in Excel, and it's best to avoid relying on ActiveSheet/ActiveCell.

When formatting the font you can likely omit everything from .Strikethrough = False onwards, unless there are settings there which you're changing.

Exiting a loop if there are no more rows you need to check (and refactoring the code a little):

Dim rw As Range
For Each rw in sCoordinateBook.Range("A7:C140")
    If rw.cells(1).value = sMastenummer Then
        sNorth = rw.cells(2).Value
        sEast = rw.cells(3).Value
        Exit Sub
    End If
 Next rw 
\$\endgroup\$
  • \$\begingroup\$ I use Range(...).Value <> "" because I seem to remember having issues with 'IsEmpty(Range(...).Value)`. Have you had the same problem? \$\endgroup\$ – user109261 Sep 7 '17 at 17:15
  • \$\begingroup\$ I typically use Len()>0 but this doesn't work well with error values (Type Mismatch, same problem with <>"") IsEmpty() returns True for empty cells and those with errors. \$\endgroup\$ – Tim Williams Sep 7 '17 at 17:35

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.