excel - Count lines of text in a cell -


i have excel spreadsheet of data work need split in vba. couple of columns have multiple lines of text , others not. i've figured out how split multiple lines of text, problem taking column single line of text , copying down. example:

company_name     drug_1      phase_2        usa                  drug_2      discontinued                   drug_3      phase_1        europe                  drug_4      discontinued   

below code using split columns b & c , can handle d manually, need column copy down rows 2-4. there's on 600 rows otherwise manually. (note: i'm putting column b below, , column c c)

sub splitter()     dim iptr1 integer     dim iptr2 integer     dim ibreak integer     dim myvar integer     dim strtemp string     dim irow integer  'column loop     irow = 0     iptr1 = 1 cells(rows.count, 1).end(xlup).row         strtemp = cells(iptr1, 1)         ibreak = instr(strtemp, vblf)         range("c1").value = ibreak             until ibreak = 0             if len(trim(left(strtemp, ibreak - 1))) > 0                 irow = irow + 1                 cells(irow, 2) = left(strtemp, ibreak - 1)             end if             strtemp = mid(strtemp, ibreak + 1)             ibreak = instr(strtemp, vblf)         loop         if len(trim(strtemp)) > 0             irow = irow + 1             cells(irow, 2) = strtemp         end if     next iptr1  'column c loop     irow = 0     iptr2 = 1 cells(rows.count, 3).end(xlup).row         strtemp = cells(iptr2, 3)         ibreak = instr(strtemp, vblf)         until ibreak = 0             if len(trim(left(strtemp, ibreak - 1))) > 0                 irow = irow + 1                 cells(irow, 4) = left(strtemp, ibreak - 1)             end if             strtemp = mid(strtemp, ibreak + 1)             ibreak = instr(strtemp, vblf)         loop         if len(trim(strtemp)) > 0             irow = irow + 1             cells(irow, 4) = strtemp         end if     next iptr2  end sub 

there bit of code call "waterfall fill" this. if can build range of cells fill (i.e. set rng_in), it. works on number of columns nice feature. can feed range of a:d , polish off blanks.

sub fillvaluedown()      dim rng_in range     set rng_in = range("b:b")      on error resume next          dim rng_cell range         each rng_cell in rng_in.specialcells(xlcelltypeblanks)             rng_cell = rng_cell.end(xlup)         next rng_cell      on error goto 0  end sub 

before , after, shows code filling down.

enter image description here enter image description here

how works

this code works getting range of blank cells. default specialcells looks usedrange because of quirk xlcelltypeblanks. there sets value of blank cell equal closest cell on top of using end(xlup). error handling in place because xlcelltypeblanks return error if nothing found. if whole column blank row @ top though (like picture), error never triggered.


Comments

Popular posts from this blog

Java 3D LWJGL collision -

spring - SubProtocolWebSocketHandler - No handlers -

methods - python can't use function in submodule -