Compiling data from multiple worksheets to a master worksheet in a single workbook - VBA Excel Macro -
question: how can make macro run faster?
i download data single workbook. data made of list of variables (string in column a) , values (string or number in column b). "possible" configuration variables exist in master worksheet. each worksheet shares variables, not all, , may have unique variable needs added variable master list. compile data in 1 master worksheet using macro:
sub comparevariabledata() dim mainws worksheet *'establishes worksheet variable* set mainws = worksheets(1) *'sets mainws master comparison* dim wscount long *'counts total number of worksheets in workbook* dim curwsnum long *'tracks current worksheet being compared* wscount = activeworkbook.worksheets.count *'gives wscount value equal number of worksheets* curwsnum = 2 wscount *'loop second worksheet last active worksheet* dim r long *'variable row in compared worksheet* dim mainwsrow long *'variable counter rows in master worksheet* mainws.cells(1, curwsnum) = worksheets(curwsnum).name *'adds name of compared worksheet first row of first worksheet* r = 3 worksheets(curwsnum).range("a" & rows.count).end(xlup).row *'loops third row of compared worksheet last used row* curstr = worksheets(curwsnum).cells(r, 1) *'creates variable curstr capture variable name first column* mainws.activate *'activates main ws next loop* if not iserror(application.match(curstr, mainws.columns("a:a"), 0)) *'if there no error in match between compare variable , master variable list* *'found* mainws.cells(application.match(curstr, mainws.columns("a:a"), 0), curwsnum) = worksheets(curwsnum).cells(r, 2) *'adds value of variable compare worksheet master worksheet* else *'not found* dim lastrow long *'makes variable lastrow add 'notfound' variable end of master list* lastrow = mainws.range("a" & rows.count).end(xlup).row + 1 *'finds last row* mainws.cells(lastrow, 1) = curstr *'adds variable master list* mainws.cells(lastrow, curwsnum) = worksheets(curwsnum).cells(r, 2) *'adds value compared worksheet* mainws.cells(lastrow, 1).interior.color = vbyellow *'highlights row* end if next next end sub
welcome stackoverflow.
for future questions should give bit more information on problem: one, example, might have included symptom you're having (how long take run?), you've tried solve problem (what research did do, , did of help?), , other relevant details (like how big data set?).
none of below tested code, should safe try or of these, assuming don't rewrite use dictionary, tim suggests:
- as tim williams suggests above, use
application.screenupdating = false
,application.calculation = xlcalculationmanual
@ start of code. sure turn these on @ end. - move
dim
statmentsr
,mainwsrow
,lastrow
out of loops (so dimensioned once, , not every loop). - explicitly dimension
curstr
: typing variable should performance since un-dimmed , default variant (if read correctly, return string in data set) - eliminating
mainws.activate
. activating , selecting items takes time, , besides don't think code needs written.
your resulting code might this:
dim mainws worksheet set mainws = worksheets(1) dim wscount long wscount = activeworkbook.worksheets.count dim curwsnum long '~~>move following within loop structures dim r long dim mainwsrow long dim lastrow long '~~>add type variable dim curstr string '~~>add track initial calculation method restoring same value dim mscalcstate string mscalcstate = application.calculation '~~>turn off updates during code run application.screenupdating = false application.calculation = xlcalculationmanual curwsnum = 2 wscount mainws.cells(1, curwsnum) = worksheets(curwsnum).name r = 3 worksheets(curwsnum).range("a" & rows.count).end(xlup).row '~~>remove mainws.activate curstr = worksheets(curwsnum).cells(r, 1) if not iserror(application.match(curstr, mainws.columns("a:a"), 0)) _ mainws.cells(application.match(curstr, mainws.columns("a:a"), _ 0), curwsnum) = worksheets(curwsnum).cells(r, 2) else lastrow = mainws.range("a" & rows.count).end(xlup).row + 1 mainws.cells(lastrow, 1) = curstr mainws.cells(lastrow, curwsnum) = worksheets(curwsnum).cells(r, 2) mainws.cells(lastrow, 1).interior.color = vbyellow end if next r next curwsnum '~~>restore update settings application.screenupdating = true application.calculation = mscalcstate
that should part way there.
Comments
Post a Comment