Excel Search VBA macro -

i have been given task of searching through large volume of data. data presented identically across around 50 worksheets. need macro searches through these sheets specific values copies cells table created in new workbook. macro needs create table headings when run.

it must search column g value 9.1 information must copied corresponding columns in table

• fha ref = same row value column g
• engine effect = same row value column f
• part number = cell j3
• part name = cell c2
• fm id = same row value column b
• failure mode & cause = same row value column c
• fmcn = same row value column c"`

if hassle create new workbook these column headings quite happy create headings myself in worksheet , have macro search , copy data rows corresponding headings.

if or backup files needed more happy provide these.

the code have @ moment based on userform ideally away , search sheets

    public sub createwsheet(module, srcwbook)         dim          = 0         srcwb = srcwbook       each ws in workbooks(srcwbook).worksheets             = + 1             if ws.name = module                 msgbox ("a worksheet module exists")                 exit sub             end if         next ws          workbooks(srcwbook).activate         worksheets.add after:=worksheets(i)         activesheet.name = module         cells(2, 2) = "fha ref"         cells(2, 3) = "engine effect"         cells(2, 4) = "part no"         cells(2, 5) = "part name"         cells(2, 6) = "fm id"         cells(2, 7) = "failure mode & cause"         cells(2, 8) = "fmcn"         cells(2, 9) = "ptr"         cells(2, 10) = "etr"          range(cells(2, 2), cells(2, 10)).font.bold = true         range(cells(1, 2), cells(1, 10)) = "interface"         range(cells(1, 2), cells(1, 10)).mergecells = true         range(cells(1, 2), cells(1, 10)).font.bold = true         workbooks(srcwbook).activate     end sub dim mainwb, srcwbook dim headerleft, headertop, headerbottom, headerright dim ntargetfmeca, npartid, nlineid, npartno, npartname, nqty, nfailuremode, nassumedsystemeffect, nassumedengineeffect dim item string dim mdest dim selections(100)   public sub controlcopyfms(mwb, swb, module)     dim      mainwb = mwb     srcwbook = swb     mdest = 2      ntargetfmeca = 0     npartid = 0     nlineid = 0     npartno = 0     npartname = 0     nqty = 0     nfailuremode = 0     nassumedsystemeffect = 0     nassumedengineeffect = 0      = 0 testform.lbselected.listcount - 1         call copyfms(module, selections(i))     next end sub         public sub copyfms(module, comp)         dim msrc          workbooks(srcwbook).sheets(comp).select         if exploreheader(comp) = 0             exit sub         end if          msrc = headerbottom + 3          while cells(msrc, nsrc).text <> ""             if cells(msrc, nindication).text <> "-"                 if cells(msrc, nindication).text <> ""                     workbooks(mainwb).worksheets(module).cells(mdest, 2) = cells(msrc, ntargetfmeca).value                     workbooks(mainwb).worksheets(module).cells(mdest, 3) = cells(msrc, npartid).value                     workbooks(mainwb).worksheets(module).cells(mdest, 4) = cells(msrc, nlineid).value                     workbooks(mainwb).worksheets(module).cells(mdest, 5) = cells(msrc, npartno).value                     workbooks(mainwb).worksheets(module).cells(mdest, 6) = cells(msrc, npartname).value                     workbooks(mainwb).worksheets(module).cells(mdest, 7) = cells(msrc, nqty).value                     workbooks(mainwb).worksheets(module).cells(mdest, 8) = cells(msrc, nfailuremode).value                     workbooks(mainwb).worksheets(module).cells(mdest, 9) = cells(msrc, nassumedengineeffect).value                     workbooks(mainwb).worksheets(module).cells(mdest, 10) = cells(msrc, nassumedsystemeffect).value                     mdest = mdest + 1                 end if             end if             msrc = msrc + 2         wend     end sub        public function exploreheader(comp)         dim m, n          m = 1         n = 1          while ((instr(1, cells(m, n).text, "engine programme:", vbtextcompare) <= 0) or (instr(1, cells(m, n).text, "br700-725", vbtextcompare) <= 0)) , n < 10             if m < 10                 m = m + 1             else                 n = n + 1                 m = 1             end if         wend          headertop = m         headerleft = n          while strcomp(cells(m, n).text, "id", vbtextcompare) <> 0 , strcomp(cells(m, n).text, "case no.", vbtextcompare) <> 0             m = m + 1         wend         headerbottom = m - 1          while cells(m, n).borders(xledgebottom).linestyle = xlcontinuous             n = n + 1         wend         headerright = n - 1          m = headertop         n = headerleft                     if n > headerright                 n = headerleft                 m = m + 1             end if              if instr(1, cells(m, n).value, "item no.:", vbtextcompare) > 0                 item = right(cells(m, n).value, len(cells(m, n).value) - instr(1, cells(m, n).value, ":", vbtextcompare))                 cells(m, n).select                 exit             end if              n = n + 1         loop while m <= headerbottom          m = headerbottom + 1         n = headerleft         while n <= headerright             if strcomp(cells(m, n).value, "id", vbtextcompare) = 0                 nid = n             end if              if strcomp(cells(m, n).value, "mitigation", vbtextcompare) = 0                 nmitigation = n             end if              if strcomp(cells(m, n).value, "remarks", vbtextcompare) = 0                 nremarks = n             end if              if strcomp(cells(m, n).value, "fmcn", vbtextcompare) = 0                 nfmcn = n             end if              if strcomp(cells(m, n).value, "indication", vbtextcompare) = 0                 nindication = n             end if              if strcomp(cells(m, n).value, "crit", vbtextcompare) = 0                 nfmcn = n             end if              if strcomp(cells(m, n).value, "detect", vbtextcompare) = 0                 nindication = n             end if              if strcomp(cells(m, n).value, "functional description", vbtextcompare) = 0                 nmitigation = n             end if              n = n + 1         wend         exploreheader = 1     end function       public sub initselections()         = 0 99             selections(i) = ""         next     end sub       public sub loadselection(comp, i)         selections(i) = comp     end sub        public sub deleteselection(i)         while selections(i) <> ""             selections(i) = selections(i + 1)             = + 1         wend     end sub 

i hope can more. code may not work 100% should enough guide you. let me know if have questions.

dim ws worksheet dim results(7, 1000000) string ''didn't know data type or how many possible results dim colvalue() variant dim i, ii, resultct long   resultct = 0  each ws in activeworkbook.worksheets ''this should result , information results array      colvalue = activesheet.range(cells(2, 7), cells(ws.usedrange.rows.count, 7)).value ''this put of column g array      = 0 ubound(colvalue)         if colvalue(i, 1) = "9.1"             results(0, resultct) = cells(i + 1, 7).value ''i think off 1, if not remove +1             results(1, resultct) = cells(i + 1, 6).value             results(2, resultct) = cells(3, 10).value             results(3, resultct) = cells(2, 3).value             results(4, resultct) = cells(i + 1, 2).value             results(5, resultct) = cells(i + 1, 3).value             results(6, resultct) = cells(i + 1, 3).value             resultct = resultct + 1         end if     next  next ws 

''at point code create worksheet , name ''starting line workbooks(srcwbook).activate

''then set active cell ever want start putting data , have like

for = 0 ubound(results, 2)     ii = 0 ubound(results)         activecell.offset(i, ii).value = results(i, ii) ''this assumes put information result in order want printed out     next next