excel vba - The following VBA code breaks. How may I keep it running? -
option base 1 sub prepareiofile() 'step 1: open final spq edpss , find earliest start date dim rowcount integer dim lastrow integer = 2 until isempty(cells(i, 1).value) = + 1 loop lastrow = - 1 rowcount = - 2 'step 2: find earliest start date in records dim earliestdate date dim firstdate date earliestdate = cdate(application.min(range("k2:k" & lastrow))) firstdate = earliestdate 'step 3: find number of months between earliest start date , specified month dim nowmonth integer dim nowyear integer nowmonth = inputbox("please specify recent month compute." & vbnewline & "note: month should between 1 , 12 only.") if nowmonth < 1 or nowmonth > 12 msgbox "you have entered invalid month." exit sub else nowmonth = nowmonth nowyear = inputbox("please specify current year compute." & vbnewline & "note: year should entered in yyyy format.") if nowyear < 2008 or nowyear > year(date) msgbox "the valid year should between year 2008 , year " & year(date) & "." exit sub else nowmonth = nowmonth nowyear = nowyear end if end if dim nowdate date dim monthrange integer nowdate = cdate("1/" & nowmonth & "/" & nowyear) earliestdate = cdate("1/" & month(firstdate) & "/" & year(firstdate)) monthrange = round((nowdate - earliestdate) / 30.4) 'step 4: prepare output file dim mypath string mypath = activeworkbook.path & "\output.xls" set newbook = workbooks.add activeworkbook.saveas mypath worksheets("sheet1").select range("a1").select activecell.formular1c1 = "basic price" range("b1").select activecell.formular1c1 = "contract no" range("c1").select activecell.formular1c1 = "project title" range("d1").select activecell.formular1c1 = "contract start" range("e1").select activecell.formular1c1 = "contract end" range("f1").select activecell.formular1c1 = "aspq" range("g1").select activecell.formular1c1 = "qty delivered" range("g2").select activecell.formular1c1 = "cumulative td" range("h2").select dim startmonth string startmonth = month(earliestdate) & "/1/" & year(earliestdate) activecell.formular1c1 = startmonth selection.numberformat = "mmmyy" dim currentmonth string = 1 monthrange currentmonth = month(cdate(dateadd("m", 1, earliestdate))) & "/1/" & year(cdate(dateadd("m", 1, earliestdate))) cells(2, 8 + i).value = currentmonth cells(2, 8 + i).numberformat = "mmmyy" earliestdate = dateadd("m", 1, earliestdate) next activeworkbook.close 'capture contract no. , accompanying information dim outputpath string outputpath = activeworkbook.path & "\output.xls" dim contractno string dim projecttitle string dim contractstart string dim contractend string dim aspq double j = 1 j = 1 lastrow contractno = cells(j + 1, 1).value projecttitle = cells(j + 1, 2).value contractstart = cells(j + 1, 11).value contractend = cells(j + 1, 12).value aspq = cells(j + 1, 14).value 'paste these information output file application.workbooks.open (outputpath) cells(j + 2, 2).value = contractno cells(j + 2, 3).value = projecttitle cells(j + 2, 4).value = contractstart cells(j + 2, 5).value = contractend cells(j + 2, 6).value = aspq activeworkbook.close savechanges:=true 'loop through bill summaries month month 'if can find, put quantity delivered month 'if cannot find, set quantity 0 dim monthtag integer dim yeartag integer dim activemonth string m = 1 monthrange application.workbooks.open (outputpath) monthtag = month(cells(2, 7 + m).value) yeartag = year(cells(2, 7 + m).value) select case monthtag case "1" activemonth = "jan" & right(yeartag, 2) case "2" activemonth = "feb" & right(yeartag, 2) case "3" activemonth = "mar" & right(yeartag, 2) case "4" activemonth = "apr" & right(yeartag, 2) case "5" activemonth = "may" & right(yeartag, 2) case "6" activemonth = "jun" & right(yeartag, 2) case "7" activemonth = "jul" & right(yeartag, 2) case "8" activemonth = "aug" & right(yeartag, 2) case "9" activemonth = "sep" & right(yeartag, 2) case "10" activemonth = "oct" & right(yeartag, 2) case "11" activemonth = "nov" & right(yeartag, 2) case "12" activemonth = "dec" & right(yeartag, 2) end select activeworkbook.close savechanges:=true dim myfolder string dim qty double dim sumqty double dim found integer dim sumfound integer myfolder = activeworkbook.path & "\bill\" if dir((myfolder & "\" & yeartag & "\bill_summary_report_" & activemonth & ".xls")) <> "" application.workbooks.open (myfolder & "\" & yeartag & "\bill_summary_report_" & activemonth & ".xls") worksheets("cement").select 'find contract coordinates x = 1 until cells(x, 1).value = "sno" x = x + 1 loop y = 1 until cells(x, y).value = "contract" y = y + 1 loop 'find qty coordinates p = 1 until cells(p, 1).value = "product" p = p + 1 loop q = 1 until cells(p, q).value = "c qty" q = q + 1 loop 'determine quantity delivered month 'this area proned problems since 1 spacing distort data 'may want manual check multiple occurences of contract no! n = 1 sumfound = 0 sumqty = 0 until isempty(cells(17 + n, y).value) if contractno = cells(17 + n, y).value found = 1 qty = cells(19 + n, q).value else found = 0 qty = 0 end if sumfound = sumfound + found sumqty = sumqty + qty n = n + 10 loop activeworkbook.close else sumqty = 0 end if application.workbooks.open (outputpath) cells(j + 2, 7 + m).value = sumqty activeworkbook.close savechanges:=true 'msgbox "m: " & m & vbnewline & "yr: " & yeartag & vbnewline & "j: " & j next m next j end sub
i think problem somewhere in data.
you have many datetime conversions, maybe 1 file contains data wrong format, string instead of date.
maybe there problem file names (01 instead of 1 or 1 instead of 01).
i suggest temporarily remove file caused break , see happen.
if work - try find problem in problematic file.
when find - try handle kind of problem in code.
Comments
Post a Comment