Extract values from cell and copy entire row with each individual value - vba

Question

I have a column which consists of 3 digit codes referring to a branch. If a person is working in multiple departments, then he/she will have multiple codes referred in that column. Below is what it would look like.
Name | Branch
ABC | 423
MNO | 367325
XYZ | 414426429
I want it to look like this.
Name | Branch
ABC | 423
MNO | 367
MNO | 325
XYZ | 414
XYZ | 426
XYZ | 429
I want to extract the value of the cell, suppose let's say the string length is 9, then that person works for 3 branches. I want to extract those 3 values and duplicate the entire row with each row containing one branch number.
A few pointers : No person can work for more than 3 branches(so maximum string length will be 9). There are about 20 columns. The column which contains the branch codes is always the same i.e. column G. The column also has empty cells and other string values like 'BIKCJHGT'. The entire column is formatted as text.
Can any one please give me the VBA code to accomplish this?
Here is the code I've used. It hasn't thrown any errors, but it's not working either.
Option Explicit
Sub MultiRecords()
Dim b As Workbook
Set b = Workbooks.Open("C:\Users\uspola00\Desktop\Headcount_Final.xlsx")
ActiveWorkbook.Sheets("Headcount").Activate
ActiveSheet.Range("G1").Select
Dim ws As Worksheet
Set ws = Sheets("Headcount")
Dim intInsertRows As Integer
Dim i As Long
i = 1
Application.ScreenUpdating = False
Do Until i > ws.Range("G" & Rows.Count).End(xlUp).Row
Dim str As String
str = LTrim(RTrim(ws.Range("G" & i)))
If Len("G" & i) = 9 Then
intInsertRows = 2
Range("G" & i + 1 & ":G" & i + intInsertRows).EntireRow.Insert
Range("A" & i & ":N" & (i + intInsertRows)).FillDown
Range("G" & (i + intInsertRows)).Value = Right(str, 3)
Range("G" & i + 1).Value = Mid(str, 4, 3)
Range("G" & i).Value = Left(str, 3)
i = i + intInsertRows
ElseIf Len("G" & i) = 6 Then
intInsertRows = 1
Range("G" & i & ":G" & i + intInsertRows).EntireRow.Insert
Range("A" & i & ":N" & (i + intInsertRows)).FillDown
Range("G" & i + intInsertRows).Value = Right(str, 3)
Range("G" & i).Value = Left(str, 3)
i = i + intInsertRows
ElseIf Len("G" & i) = 3 Then
intInsertRows = 0
i = i + intInsertRows
ElseIf IsEmpty(Range("G" & i)) Then
i = i + 0
End If
i = i + 1
Loop
End Sub

Answer 1

Try this:
Sub MultiRecords()
Dim b As Workbook
Dim ws As Worksheet
Dim c As Range, v, i As Long
Set b = Workbooks.Open("C:\Users\uspola00\Desktop\Headcount_Final.xlsx")
Set ws = b.Sheets("Headcount")
Set c = ws.Cells(Rows.Count, "G").End(xlUp)
Do
v = Trim(c.Value)
If v Like "######" Or v Like "#########" Then
i = Len(v) / 3
c.Offset(1, 0).Resize(i - 1).EntireRow.Insert
c.Resize(i).EntireRow.FillDown
c.Value = Left(v, 3)
c.Offset(1, 0).Value = Mid(v, 4, 3)
If Len(v) = 9 Then c.Offset(2, 0).Value = Right(v, 3)
End If
If c.Row = 1 Then Exit Do
Set c = c.Offset(-1, 0)
Loop
End Sub