excel - VBA script to count string, insert rows, copy row, split cell -

the department provides me spreadsheet used in database includes multiple text in cell. in order link data have turn multiple rows. example: lc123/lc463/lc9846 needs have entire row copied 1 "lc" string in each row- cell1 cell2 lc123 cell1 cell2 lc463 cell1 cell2 lc9846

i tried these 2 subroutines failed

sub insert_row() dim j long j = inputbox(=sum(len(activecell)-len(substitute(activecell,"lc",""))-1) activecell.entirerow.copy activecell.offset(j).entirerow.insert shift:=xldown end sub  sub splitandtranspose() dim n() string n = split(activecell, chr(10)) activecell.resize(ubound(n) + 1) = worksheetfunction.transpose(n) end sub 

the 2nd subroutine split , copy doesn't insert rows, writes on rows below it.

'in memory' method

inserting rows necessary perhaps simple understand, performance of making thousands of seperate row inserts not good. fine 1 off (perhaps need one-off) , should take minute or 2 run thought heck , wrote approach splits data in memory using collection , arrays. run in order of seconds.

i have commented doing.

sub processdata()     dim c collection     dim arr, recordvector     dim long, j long     dim rng range     dim part, parts      'replace code assign right range etc     set rng = activesheet.usedrange     j = 3 'replace right column index, or work out using range.find etc      arr = rng.value 'load data      'process data adding additional rows etc     set c = new collection     = 1 ubound(arr, 1)         parts = split(arr(i, j), "/") 'split data based on "/"         each part in parts 'loop through each "lc" thing             recordvector = getvector(arr, i) 'get row data             recordvector(j) = part 'replace "lc" thing             c.add recordvector 'add our results collection         next part     next      'prepare dump data worksheet     rng.clear      rng.parent         .range( _             rng.cells(1, 1), _             rng.cells(1, 1).offset(c.count - 1, ubound(arr, 2) - 1)) _             .value = getcollectionofvectorstoarray(c)     end  end sub  'helper method return vector representing our row data private function getvector(dataarray, datarecordindex long)     dim j long, tmparr     redim tmparr(lbound(dataarray, 2) ubound(dataarray, 2))     j = lbound(tmparr) ubound(tmparr)         tmparr(j) = dataarray(datarecordindex, j)     next j     getvector = tmparr end function 'helper method return array collection of vectors function getcollectionofvectorstoarray(c collection)     dim long, j long, arr     redim arr(1 c.count, lbound(c(1), 1) ubound(c(1), 1))     = 1 c.count         j = lbound(arr, 2) ubound(arr, 2)             arr(i, j) = c(i)(j)         next j     next     getcollectionofvectorstoarray = arr end function 

edit:

alternative "range insert" method.

it slower (although made number of discrete insert , copy operations based on original row count, not recursive sweep not bad) simpler understand , perhaps tweak if needed. should run in order of couple of minutes.

sub processdata_rangemethod()     dim rng range     dim colindex long     dim parts     dim currrowindex long      'replace code assign right range etc     set rng = activesheet.usedrange      colindex = 3 'replace right column index, or work out using range.find etc      application.screenupdating = false     application.calculation = xlcalculationmanual      currrowindex = 1     until currrowindex > rng.rows.count         parts = split(rng.cells(currrowindex, colindex), "/")         if ubound(parts) > 0             rng.range(rng.cells(currrowindex + 1, 1), rng.cells(currrowindex + ubound(parts), rng.columns.count)).insert xlshiftdown             rng.rows(currrowindex).copy rng.range(rng.cells(currrowindex + 1, 1), rng.cells(currrowindex + ubound(parts), rng.columns.count))             rng.range(rng.cells(currrowindex, colindex), rng.cells(currrowindex + ubound(parts), colindex)).value = application.transpose(parts)         end if         currrowindex = currrowindex + 1 + ubound(parts)     loop      application.screenupdating = true     application.calculation = xlcalculationautomatic  end sub