excel - VBA - Possible to create a button that links to code? -

i have written code program outputs 3 columns of information printing file name. typically run program 20 files in folder don't overwhelm things info, given there on 2000 files.

is possible create button output same information single file name entry? want able type file name in, hit search, , have search through folder of on 2000 files output 3 columns of info particular file.

something this:

option explicit  sub loopthroughdirectory()      const row_header long = 10      dim objfso object     dim objfolder object     dim objfile object     dim myfolder string     dim startsht worksheet, ws worksheet     dim wb workbook     dim integer     dim lastrow integer, erow integer     dim height integer     dim rowlast long     dim f string     dim dict object     dim hc range, hc1 range, hc2 range, hc3 range, d range      set startsht = workbooks("masterfile.xlsm").sheets("sheet1")      'turn screen updating off - makes program faster     application.screenupdating = false     'application.updatelinks = false      'location of folder in desired tds files     myfolder = "c:\users\trembos\documents\tds\progress\"      'find headers on sheet     set hc1 = headercell(startsht.range("b1"), "holder")     set hc2 = headercell(startsht.range("c1"), "cutting tool")      'create instance of filesystemobject     set objfso = createobject("scripting.filesystemobject")     'get folder object     set objfolder = objfso.getfolder(myfolder)     = 2         'loop through directory file , print names '(1)     each objfile in objfolder.files         if lcase(right(objfile.name, 3)) = "xls" or lcase(left(right(objfile.name, 4), 3)) = "xls" '(2)             'print file name column 1              'open folder , file name, not update links             set wb = workbooks.open(filename:=myfolder & objfile.name, updatelinks:=0)             set ws = wb.activesheet   '(3)                 'find cutting tool on source sheet                 set hc = headercell(ws.cells(row_header, 1), "cutting tool")                 if not hc nothing                      set dict = getuniques(hc.offset(1, 0))                     if dict.count > 0                         set d = startsht.cells(rows.count, hc2.column).end(xlup).offset(1, 0)                         'add values masterfile, column 3                         d.resize(dict.count, 1).value = application.transpose(dict.keys)                     end if                 else                     'header not found on source worksheet                 end if  '(4)                 'find holder on source sheet                 set hc3 = headercell(ws.cells(row_header, 1), "holder")                 if not hc3 nothing                      set dict = getuniques(hc3.offset(1, 0))                     if dict.count > 0                         set d = startsht.cells(rows.count, hc1.column).end(xlup).offset(1, 0)                         'add values master list, column 2                         d.resize(dict.count, 1).value = application.transpose(dict.keys)                     end if                 else                     'header not found on source worksheet                 end if  '(5)             wb                'print tds information                 each ws in .worksheets                         'print file name column 1                         startsht.cells(i, 1) = objfile.name                         'print tds name j1 cell column 4                         ws                             .range("j1").copy startsht.cells(i, 4)                         end                         = getlastrowinsheet(startsht) + 1                 'move next file                 next ws '(6)                 'close, not save changes opened files                 .close savechanges:=false             end         end if     'move next file     next objfile     'turn screen updating on     application.screenupdating = true     activewindow.scrollrow = 1 '(7) end sub  '(8) 'get unique column values starting @ cell c function getuniques(ch range) object     dim dict object, rng range, c range, v     set dict = createobject("scripting.dictionary")     each c in ch.parent.range(ch, ch.parent.cells(rows.count, ch.column).end(xlup)).cells         v = trim(c.value)         if len(v) > 0 , not dict.exists(v)             dict.add v, ""         end if     next c     set getuniques = dict end function  '(9) 'find header on row: returns nothing if not found function headercell(rng range, sheader string) range     dim rv range, c range     each c in rng.parent.range(rng, rng.parent.cells(rng.row, columns.count).end(xltoleft)).cells         if trim(c.value) = sheader             set rv = c             exit         end if     next c     set headercell = rv end function  '(10) function getlastrowincolumn(theworksheet worksheet, col string)     theworksheet         getlastrowincolumn = .range(col & .rows.count).end(xlup).row     end end function  '(11) function getlastrowinsheet(theworksheet worksheet) dim ret     theworksheet         if application.worksheetfunction.counta(.cells) <> 0             ret = .cells.find(what:="*", _                           after:=.range("a1"), _                           lookat:=xlpart, _                           lookin:=xlformulas, _                           searchorder:=xlbyrows, _                           searchdirection:=xlprevious, _                           matchcase:=false).row         else             ret = 1         end if     end     getlastrowinsheet = ret end function 

here's simple example:

'the directory containing files const tds_path = "c:\data\tds search\"  sub openfilecopycolumn()  'clear our list sheets("sheet1").range("b6:d31").clear  'very basic input checking - can add more if sheets("sheet1").range("c3") = ""     msgbox("please enter file search for")     exit sub end if  'if file searching exists in path if dir(tds_path & sheets("sheet1").range("c3")) <> ""      'disable screen updating performance/aesthetics     application.screenupdating = false      'open workbook searched (readonly)     workbooks.open tds_path & sheets("sheet1").range("c3"), readonly:=true      'copy range interested in     activeworkbook.sheets("sheet1").range("a2:c16").copy thisworkbook.sheets("sheet1").range("b6")      'close file     activeworkbook.close (false)      're-enable screen updating     application.screenupdating = true  else     'let user know if file not found     msgbox("file not found!") end if end sub 

sheet1 of tds search workbook:

sheet1 of file tools1.xlsx:

create button , assign macro:

edit:

first, decide "search cell" be.

i chose range("c3") on sheet("sheet1") arbitrarily in example above, yours can cell.

then, search , open using code above (all of goes in macro assigned button - see screenshots how assign macro button).

instead of using line:

'copy range interested in activeworkbook.sheets("sheet1").range("a2:c16").copy thisworkbook.sheets("sheet1").range("b6") 

if want run macro stored in newly opened workbook, can use:

activeworkbook.application.run "macroname" 

there's more info here:

http://www.mrexcel.com/forum/excel-questions/51660-calling-macro-another-workbook.html