WBS VBA Code

[Petar Willhite]

I have been searching for a WBS numbering Code and have been unsuccessful so far. So I came here and I am confident I can get an answer.

I am needing the WBS code to be based on Column G in my sheet. It will be based on "account code" length as follows for example:

Column A Column G
12 61
12.1 61.03
12.1.1 61.03.02
12.1.1.1 61.03.02.000
12.1.1.1.1 61.03.02.000.08
12.1.1.1.2 61.03.02.000.08
12.1.1.1.3 61.03.02.000.08
12.1.2 61.03.06
12.2.1 61.03.06.002
12.1.2.1.1 61.03.06.002.02
12.1.1.1.2 61.03.06.002.04

I hard entered these but there are around 1,000 cells that will need a WBS assigned to them.

Thanks for the help in advance.

 

[Luke M]

Hi Petar, and welcome to the forum!

This macro will create all your numbers for you super-fast.

Sub CreateWBS()
Dim lastRow As Long
Const colWBS As String = "G"
Dim myVals As Variant
Dim lngOut As Long
Dim myOutline(1 To 8) As Long
Dim prevIndent As Long
Dim strWBS As String
Dim i As Long

'Setup initial values
myOutline(1) = Range("A2").Value
prevIndent = 0
For lngOut = 2 To 8
    myOutline(lngOut) = 0
Next lngOut

Application.ScreenUpdating = False
With Worksheets("Import Form")
    'Find last row on sheet
    lastRow = .Cells(.Rows.Count, colWBS).End(xlUp).Row
    For i = 3 To lastRow
        myVals = Split(.Cells(i, colWBS).Value, ".")
        If UBound(myVals) < prevIndent Then
            'We went up a new level, so clear the extra outline
            For lngOut = UBound(myVals) + 2 To 8
                myOutline(lngOut) = 0
            Next lngOut
        End If
        prevIndent = UBound(myVals)
        myOutline(prevIndent + 1) = myOutline(prevIndent + 1) + 1
       
        'Build WBS string
        strWBS = ""
        For lngOut = 1 To 8
            If myOutline(lngOut) = 0 Then Exit For
            strWBS = strWBS & "." & myOutline(lngOut)
        Next lngOut
        'Remove leading period
        strWBS = Mid(strWBS, 2)
        'Export to cell
        .Cells(i, "A").Value = strWBS
    Next i
End With
Application.ScreenUpdating = True
End Sub

To use the macro, copy the above. Then in your workbook, right-click on a sheet tab, view code. In the window that appears (the VBE), go to Insert - Module. Paste the code you just copied. Close the VBE window. Back in your workbook, you can now run the macro by pressing Alt+F8 and choosing the CreateWBS macro.

 

[YasserKhalil]

Hello Petar
Here's another solution

Sub Treat()
    Dim WS As Worksheet, SH As Worksheet
    Dim Cell As Range, RngA As Range, RngD As Range, rngArea As Range
    Dim wsLR As Long, shLR As Long, I As Long
    Dim WF As Variant
   
    Set WF = Application.WorksheetFunction
    Set WS = Sheets("Codes"): Set SH = Sheets("Import Form")
    wsLR = WS.Cells(Rows.Count, 1).End(xlUp).Row
    shLR = SH.Cells(Rows.Count, 2).End(xlUp).Row
    Set RngA = WS.Range("A2:A" & wsLR): Set RngD = WS.Range("D2:D" & wsLR)
   
    Application.ScreenUpdating = False
    For Each Cell In SH.Range("G2", SH.Range("G" & Rows.Count).End(xlUp))
        If IsEmpty(Cell.Offset(, -5)) Then
            Cell.Offset(, -6).Value = WF.Index(RngA, WF.Match(Cell.Value, RngD, 0))
        End If
    Next Cell
   
    For Each rngArea In Range("A1:A" & shLR).SpecialCells(xlCellTypeBlanks).Areas
        For I = 1 To rngArea.Count
            rngArea(I).Value = rngArea(0).Value & "." & I
        Next I
    Next
    Application.ScreenUpdating = True
End Sub

 

[Petar Willhite]

Hi Petar, and welcome to the forum!

This macro will create all your numbers for you super-fast.

Sub CreateWBS()
Dim lastRow As Long
Const colWBS As String = "G"
Dim myVals As Variant
Dim lngOut As Long
Dim myOutline(1 To 8) As Long
Dim prevIndent As Long
Dim strWBS As String
Dim i As Long

'Setup initial values
myOutline(1) = Range("A2").Value
prevIndent = 0
For lngOut = 2 To 8
    myOutline(lngOut) = 0
Next lngOut

Application.ScreenUpdating = False
With Worksheets("Import Form")
    'Find last row on sheet
    lastRow = .Cells(.Rows.Count, colWBS).End(xlUp).Row
    For i = 3 To lastRow
        myVals = Split(.Cells(i, colWBS).Value, ".")
        If UBound(myVals) < prevIndent Then
            'We went up a new level, so clear the extra outline
            For lngOut = UBound(myVals) + 2 To 8
                myOutline(lngOut) = 0
            Next lngOut
        End If
        prevIndent = UBound(myVals)
        myOutline(prevIndent + 1) = myOutline(prevIndent + 1) + 1
      
        'Build WBS string
        strWBS = ""
        For lngOut = 1 To 8
            If myOutline(lngOut) = 0 Then Exit For
            strWBS = strWBS & "." & myOutline(lngOut)
        Next lngOut
        'Remove leading period
        strWBS = Mid(strWBS, 2)
        'Export to cell
        .Cells(i, "A").Value = strWBS
    Next i
End With
Application.ScreenUpdating = True
End Sub

To use the macro, copy the above. Then in your workbook, right-click on a sheet tab, view code. In the window that appears (the VBE), go to Insert - Module. Paste the code you just copied. Close the VBE window. Back in your workbook, you can now run the macro by pressing Alt+F8 and choosing the CreateWBS macro.

Thank you Luke that worked perfectly!