CODEWITHSUNDEEP
vbaexcel
dhanya
dhanya

Reputation: 265

VBA: Code review and set border for the fileds which change frequently

Kindly help me to set border for a set of fields which use to change as per the data (Weeks of a month) provided by the user, I tried few things but nothing going through because when the fields changes it will just go crazy

For the first time i set values as Jan 2018 & Feb 2018

The code

Sub ClearPage()

    Sheets("WeekWise_Revenue").Select
    Cells.Select
    Selection.Delete Shift:=xlUp

    Call Set_Basicdetails

End Sub

Sub Set_Basicdetails()

    Range("3:3,5:5").Select
    Range("C3").Activate
    With Selection.Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
    Range("4:4,6:6").Select
    Range("C4").Activate
    With Selection.Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With

' Macro2 Macro

    Range("A2").Select
    ActiveCell.FormulaR1C1 = "Country"
    Range("A2:B2").Select
    Selection.Merge


    Range("A3").Select
    ActiveCell.FormulaR1C1 = "US"
    Range("A3:B4").Select
    Selection.Merge
      With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = 0.399975585192419
        .PatternTintAndShade = 0
      End With

    Range("A5").Select
    ActiveCell.FormulaR1C1 = "India"
    Range("A5:B6").Select
    Selection.Merge
      With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
      End With


    Range("C3").Select
    ActiveCell.FormulaR1C1 = "Senior Ops"
    Range("C4").Select
    ActiveCell.FormulaR1C1 = "Ops Eng"
    Range("C5").Select
    ActiveCell.FormulaR1C1 = "Senior Ops"
    Range("C6").Select
    ActiveCell.FormulaR1C1 = "Ops Eng"
    Range("C7").Select
    ActiveCell.FormulaR1C1 = "Revenue"

    Columns("A:C").Select
    Columns("A:C").EntireColumn.AutoFit

Call SetDate

End Sub

Sub SetDate()

    Dim intDay As Integer, firstIter As Integer
    Dim startMonth As Date, endMonth As Date
    Dim str As String
    Dim IsStartMonth As Boolean, IsEndMonth As Boolean
    Dim Rng As Range, rng1 As Range, rng2 As Range
    Dim i As Long
    Dim ws As Worksheet

    Application.ScreenUpdating = False
    firstIter = 1
    Set ws = ThisWorkbook.Sheets("WeekWise_Revenue")  'change Sheet4 to your sheet
    IsStartMonth = False
    IsEndMonth = False
    Do
        If Not IsStartMonth Then
        'get start date
            str = InputBox("Enter Start Date in month-year format " & vbCrLf & "(like Sep 2017 or September 2017)", "Date")
            If IsDate(str) Then         'if entery is valid date
                startMonth = str
                IsStartMonth = True
            ElseIf IsEmpty(str) Then    'if nothing is entered
                IsStartMonth = True
            ElseIf StrPtr(str) = 0 Then 'user clicks close
                IsStartMonth = True
                Exit Sub
            Else                        'display input box again
                Call MsgBox("Enter a valid date", vbCritical + vbOKOnly, "Date Only")
            End If
        Else
        'get end date
            str = InputBox("Enter End Date in month-year format " & vbCrLf & "(like Sep 2017 or September 2017)", "Date")
            If IsDate(str) Then         'if entery is valid date
                endMonth = DateAdd("d", -1, DateAdd("m", 1, str))
                IsEndMonth = True
            ElseIf IsEmpty(str) Then    'if nothing is entered
                IsEndMonth = True
            ElseIf StrPtr(str) = 0 Then 'user clicks close
                IsEndMonth = True
                Exit Sub
            Else                        'display input box again
                Call MsgBox("Enter a valid date", vbCritical + vbOKOnly, "Date Only")
            End If
        End If
    Loop Until IsStartMonth And IsEndMonth

    Set Rng = ws.Range("D2")
    ws.Range("C2") = "Role"
    Set rng1 = Rng.Offset(-1, i)
    intDay = intDay + 1

    Do
        If Format(startMonth + intDay, "ddd") = "Mon" Then      'check whether date is Monday
            Rng.Offset(-1, i).Value = MonthName(Format(startMonth + intDay, "m"))
            Rng.Offset(0, i).Value = Format(startMonth + intDay, "d")   'display monday dates
            i = i + 1
            intDay = intDay + 7

            'merge cells in Row 1
            If rng1.Value = Rng.Offset(-1, i - 1).Value Then
                If firstIter <> 1 Then
                    Rng.Offset(-1, i - 1).Value = ""
                End If
                firstIter = 0
                With Range(rng1, Rng.Offset(-1, i - 1))
                    .Merge
                    .HorizontalAlignment = xlCenter
                End With
            Else
                Set rng1 = Rng.Offset(-1, i - 1)
            End If

        Else
            intDay = intDay + 1
        End If
    Loop Until CDate(startMonth + intDay) > CDate(endMonth) 'loop till start date is less then end date
Application.ScreenUpdating = True

Call Set_border
End Sub

Code to set border where I am facing issue

Sub Set_border()

    Range("D1").Select
    LastRow = Cells(Rows.Count, 10).End(xlUp).Row
    Range("D1:D" & LastRow).Select
    ''ActiveCell.Offset(4, 0).Select
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select


    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With

End Sub

I am expecting something like this

enter image description here

This is working fine but next time when i run the code and enter Jan 2018 only but the border will be get added to all the fileds which was selected previously, I tried to delete all the fields before the main code starts but facing same issue

Upvotes: 0

Views: 89

Answers (1)

Sercho
Sercho

Reputation: 305

My guess for the error would be the use of Column 10 in your LastRow definition. I have made some changes below.

From your example dataset, it seems like "Role" is in Column C, and "January" starts in Column D?

If so, I think you need to adjust your code to be something like this:

Sub Set_border()
    Range("C2").Select
    LastRow = Cells(Rows.Count, 3).End(xlUp).Row
    LastCol = Cells(2, Columns.Count).End(xlToLeft).Column
    Range("A2:" & Cells(LastRow, LastCol).Address).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    Range("D1:" & Cells(1, LastCol).Address).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
End Sub

Upvotes: 1

Related Questions