VBA to insert row on certain condition

[MiniFav]

Hey everyone, Formulas have taken me so far but now feel like i need VBA to help me out.

With the table below I have data in column H and along side there may be data in Column I.
I wish to have a new row created if there is data in Column I and then the value inserted into the column H space created.
This may sometimes have several references where ideally I would like new rows for each or the ability to re-run the code until there is nothing left in column I.

Anyone have any help for this?

MPD with formulas MF.xls
	H	I
385	000-28-210-700-A01
386	000-28-520-711-A01	00-28-620-711-A01
387	000-28-520-711-A01	00-28-620-711-A01
388	000-28-520-712-A01	00-28-620-712-A01
389	000-28-520-712-A01	00-28-620-712-A01
390	000-28-520-713-A01	00-28-520-713-A02 000-28-620-713-A01 000-28-620-713-A02
Sheet1

 

[saboh12617]

Hello,

I'm sorry I cannot figure out what you want. Could you provide the expected output for the example you posted? Thank you.

 

[PeteWright]

Hi @MiniFav
Try the below code on a copy of your workbook

Option Explicit
Option Base 1
Sub test()
   Dim w As Worksheet, r As Range, l As Long, j As Long, k As Long
   Dim H() As Variant, I() As Variant
   Set w = ActiveWorkbook.ActiveSheet
   l = w.Cells(Rows.Count, "I").End(xlUp).Row
   Set r = w.Range(Cells(1, "H"), Cells(l, "I"))
   ReDim H(l): ReDim I(l)
   For j = 1 To l
      H(j) = r(j, 1)
      I(j) = r(j, 2)
   Next j
   k = 1
   For j = 1 To UBound(I)
      If I(j) <> "" Then
         w.Cells(k, "H") = ""
         w.Cells(k, "I") = ""
         w.Cells(k, 1).EntireRow.Insert (xlShiftDown)
         w.Cells(k, "H") = H(j)
         w.Cells(k + 1, "H") = I(j)
         k = k + 2
      Else
         k = k + 1
      End If
   Next j
End Sub

 

[Peter_SSs]

Is this what you mean?
Test with a copy of your workbook.

Sub Test()
  Dim a As Variant, b As Variant, itm As Variant
  Dim i As Long, k As Long
  
  ReDim b(1 To Rows.Count, 1 To 2)
  With Range("H385:I" & Range("H" & Rows.Count).End(xlUp).Row)
    a = .Value
    For i = 1 To UBound(a)
      k = k + 1: b(k, 1) = a(i, 1)
      If Len(a(i, 2)) > 0 Then
        For Each itm In Split(a(i, 2), Chr(10))
          k = k + 1: b(k, 1) = itm
        Next itm
      End If
    Next i
    .Resize(k).Value = b
  End With
End Sub

Before:

MiniFav.xlsm
	H	I
385	000-28-210-700-A01
386	000-28-520-711-A01	00-28-620-711-A01
387	000-28-520-711-A01	00-28-620-711-A01
388	000-28-520-712-A01	00-28-620-712-A01
389	000-28-520-712-A01	00-28-620-712-A01
390	000-28-520-713-A01	00-28-520-713-A02 000-28-620-713-A01 000-28-620-713-A02
391
Sheet1

After:

MiniFav.xlsm
	H	I
385	000-28-210-700-A01
386	000-28-520-711-A01
387	00-28-620-711-A01
388	000-28-520-711-A01
389	00-28-620-711-A01
390	000-28-520-712-A01
391	00-28-620-712-A01
392	000-28-520-712-A01
393	00-28-620-712-A01
394	000-28-520-713-A01
395	00-28-520-713-A02
396	000-28-620-713-A01
397	000-28-620-713-A02
398
Sheet1

 

[Peter_SSs]

Looking at the question again, this may be more what is wanted? (Again test with a copy)

Sub Test_v2()
  Dim Bits As Variant
  Dim r As Long, rws As Long
  
  Const TopRow As Long = 385 '<- Edit starting row as required
  
  Application.ScreenUpdating = False
  For r = Range("I" & Rows.Count).End(xlUp).Row To TopRow Step -1
    Bits = Split(Range("I" & r).Value, Chr(10))
    rws = UBound(Bits) + 1
    If rws > 0 Then
      Rows(r + 1).Resize(rws).Insert
      Range("H" & r + 1).Resize(rws).Value = Application.Transpose(Bits)
      Range("I" & r).ClearContents
    End If
  Next r
  Application.ScreenUpdating = True
End Sub

 

[MiniFav]

Looking at the question again, this may be more what is wanted? (Again test with a copy)

Sub Test_v2()
  Dim Bits As Variant
  Dim r As Long, rws As Long
 
  Const TopRow As Long = 385 '<- Edit starting row as required
 
  Application.ScreenUpdating = False
  For r = Range("I" & Rows.Count).End(xlUp).Row To TopRow Step -1
    Bits = Split(Range("I" & r).Value, Chr(10))
    rws = UBound(Bits) + 1
    If rws > 0 Then
      Rows(r + 1).Resize(rws).Insert
      Range("H" & r + 1).Resize(rws).Value = Application.Transpose(Bits)
      Range("I" & r).ClearContents
    End If
  Next r
  Application.ScreenUpdating = True
End Sub

Thank you, this worked exactly as I had hoped for.
Can i just ask if this is a standard code? as in if I search for each bit I will be able to teach myself how each part works for future use?