excel - Loop to go through a list of values -
i have macro goes through column on master spreadsheet, exports rows value input @ start matches value in column. saves new worksheet value. here code have:
option explicit public const l_headerrow long = 2 'the header row of data sheet public const l_distancecol long = 5 'the column containing distance values public sub exportdistance() dim ws_data worksheet, wb_export workbook, ws_export worksheet dim l_inputrow long, l_outputrow long dim l_lastcol long dim l_numberofmatches long dim s_distance string, l_distance long dim s_exportpath string, s_exportfile string, s_pathdelimiter string set ws_data = activesheet s_distance = inputbox("enter distance export new file", "enter distance") if s_distance = "" exit sub l_distance = clng(s_distance) l_numberofmatches = worksheetfunction.match(l_distance, ws_data.columns(5), 0) if l_numberofmatches <= 0 exit sub 'application.screenupdating = false 'application.calculation = xlcalculationmanual application.displayalerts = false on error resume next call application.workbooks.add set wb_export = application.workbooks(application.workbooks.count) set ws_export = wb_export.worksheets(1) call wb_export.worksheets("sheet2").delete call wb_export.worksheets("sheet3").delete application.displayalerts = true ws_export.name = getnextsheetname(ws_data.name & "-" & s_distance, wb_export) call ws_data.rows(1).resize(l_headerrow).copy call ws_export.rows(1).resize(l_headerrow).select call ws_export.paste l_outputrow = l_headerrow + 1 l_lastcol = ws_data.usedrange.columns.count l_inputrow = l_headerrow + 1 ws_data.usedrange.rows.count if ws_data.cells(l_inputrow, l_distancecol).value = l_distance call ws_data.range(ws_data.cells(l_inputrow, 1), ws_data.cells(l_inputrow, l_lastcol)).copy call ws_export.rows(l_outputrow).select call ws_export.paste l_outputrow = l_outputrow + 1 elseif ws_data.cells(l_inputrow, l_distancecol).value = l_distance call ws_data.range(ws_data.cells(l_inputrow, 1), ws_data.cells(l_inputrow, l_lastcol)).copy call ws_export.rows(l_outputrow).select call ws_export.paste l_outputrow = l_outputrow + 1 end if next l_inputrow s_exportpath = thisworkbook.path s_pathdelimiter = application.pathseparator if right(s_exportpath, 1) <> s_pathdelimiter s_exportpath = s_exportpath & s_pathdelimiter s_exportpath = s_exportpath & "output" & s_pathdelimiter if dir(s_exportpath) = empty call mkdir(s_exportpath) end if select case application.defaultsaveformat case xlopenxmlworkbook s_exportfile = s_distance & ".xlsx" case xlopenxmlworkbookmacroenabled s_exportfile = s_distance & ".xlsm" case xlexcel12 s_exportfile = s_distance & ".xlsb" case xlexcel8 s_exportfile = s_distance & ".xls" case xlcsv s_exportfile = s_distance & ".csv" case else s_exportfile = s_distance end select call wb_export.saveas(filename:=s_exportpath & s_exportfile, fileformat:=application.defaultsaveformat) application.calculation = xlcalculationautomatic application.screenupdating = true end sub public function getnextsheetname(s_name string, optional wb_book workbook) string dim l_findex long dim s_target string if wb_book nothing set wb_book = activeworkbook s_name = left(s_name, 31) if isvalidsheet(wb_book, s_name) l_findex = 1 s_target = left(s_name, 27) & " (" & l_findex & ")" while isvalidsheet(wb_book, s_target) l_findex = l_findex + 1 if l_findex < 10 s_target = left(s_name, 27) & " (" & l_findex & ")" elseif l_findex < 100 s_target = left(s_name, 26) & " (" & l_findex & ")" elseif l_findex < 1000 s_target = left(s_name, 25) & " (" & l_findex & ")" end if loop getnextsheetname = s_target else getnextsheetname = s_name end if end function public function isvalidsheet(wbsearchbook workbook, v_testindex variant) boolean dim v_index variant on error goto exitline v_index = wbsearchbook.worksheets(v_testindex).name isvalidsheet = true exit function exitline: isvalidsheet = false end function
please me make loop through list of values, rather having manually run macro each time , input value myself?
download example here.
this simple example of how loop through 1 range , loop through range find values. loops through column d , loops through column a, when finds match something, column d has taken place of inputbox.
run macro
the code
sub dblloop() dim alp range 'column dim dlp range, drw long 'column d dim d range, range set alp = columns("a:a").specialcells(xlcelltypeconstants, 23) drw = cells(rows.count, "d").end(xlup).row set dlp = range("d2:d" & drw) 'start loop 'loops through column d , finds value 'in column a, , each d in dlp.cells 'loops through column d each in alp.cells 'loops through column if d = 'when match, 'this actual code go range("a" & a.row & ":b" & a.row).copy cells(rows.count, "f").end(xlup).offset(1) end if next 'keeps going through column next d 'next item in column d end sub
Comments
Post a Comment