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.

enter image description here

run macro

enter image description here

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

Popular posts from this blog

php - Invalid Cofiguration - yii\base\InvalidConfigException - Yii2 -

How to show in django cms breadcrumbs full path? -

ruby on rails - npm error: tunneling socket could not be established, cause=connect ETIMEDOUT -