The object invoked as disconnected from its clients. - To many she
Hi All,
I have a problem with vba code (excel macro) generating many sheets. It seems to crush at creating 300th sheet. I'm running it on notebook: MS Excel 2003 Win XP SP2 1 GB RAM Intel Pentium 1.73GHz I've tried to run it also at another notebook: MS Excel 2003 Win XP SP2 2 GB RAM Core 2 Duo 2,00GHz and i got the same error. It stops at line: Set NewSheet = oBook.Sheets(1) Throwing an error: Run-time error '-2147417848 (80010108)' Automation error The object invoked as disconnected from its clients. If you can give me any hint it would be wonderful. That's not my code, I have to workout this problem because it worked perfectly as long as it had to generated about 150 sheets. Since the document grow bigger I had to face this problem. The full code: macro name is GenerateTestScripts Dim K_DATA0 Dim K_DATA1 Dim K_DATA2 Dim K_DATA3 Dim K_DATA4 Dim K_DATA5 Dim K_DATA6 Dim K_DATA7 Dim K_DATA8 Dim K_DATA9 Dim K_DATA10 Dim K_DATA11 Dim K_DATA12 Dim K_DATA13 Dim K_DATA14 Dim K_DATA15 Dim K_DATA16 Dim K_DATA17 Dim K_DATA18 Dim K_DATA19 Dim K_DATA20 Dim K_DATA21 Dim K_DATA22 Dim K_DATA23 Dim K_DATA24 Dim K_DATA25 Dim K_DATA26 Dim K_DATA27 Dim K_DATA28 Dim K_DATA29 Dim K_DATA30 Dim K_DATA31 Dim K_DATA32 Dim K_DATA33 Dim K_DATA34 Dim K_DATA35 Dim K_DATA36 Dim K_DATA37 Dim K_DATA38 Dim K_DATA39 Dim K_DATA40 Function SF_countLines(ByVal Haystack As String) As Long 'count the number of occurences of needle in haystack 'SF_count(" This is my string ","i") returns 3 maxCharsPerLine = 50 numlines = 0 Needle = Chr(10) Dim i As Long, j As Long Position = InStr(1, Haystack, Needle, vbTextCompare) If Position = 0 Then hsLen = Len(Haystack) SF_countLines = Application.WorksheetFunction.Ceiling(Len(Haystack ) / maxCharsPerLine, 1) Else Haystack1 = Mid(Haystack, 1, Position) Haystack2 = Mid(Haystack, Position + 1, Len(Haystack) - Position) numlines = Application.WorksheetFunction.Ceiling(Len(Haystack 1) / maxCharsPerLine, 1) numlines = numlines + SF_countLines(Haystack2) SF_countLines = numlines End If End Function Function DataReplace(STRIN) As String STRIN = Replace(STRIN, "%DATA0%", K_DATA0) STRIN = Replace(STRIN, "%DATA1%", K_DATA1) STRIN = Replace(STRIN, "%DATA2%", K_DATA2) STRIN = Replace(STRIN, "%DATA3%", K_DATA3) STRIN = Replace(STRIN, "%DATA4%", K_DATA4) STRIN = Replace(STRIN, "%DATA5%", K_DATA5) STRIN = Replace(STRIN, "%DATA6%", K_DATA6) STRIN = Replace(STRIN, "%DATA7%", K_DATA7) STRIN = Replace(STRIN, "%DATA8%", K_DATA8) STRIN = Replace(STRIN, "%DATA9%", K_DATA9) STRIN = Replace(STRIN, "%DATA10%", K_DATA10) STRIN = Replace(STRIN, "%DATA11%", K_DATA11) STRIN = Replace(STRIN, "%DATA12%", K_DATA12) STRIN = Replace(STRIN, "%DATA13%", K_DATA13) STRIN = Replace(STRIN, "%DATA14%", K_DATA14) STRIN = Replace(STRIN, "%DATA15%", K_DATA15) STRIN = Replace(STRIN, "%DATA16%", K_DATA16) STRIN = Replace(STRIN, "%DATA17%", K_DATA17) STRIN = Replace(STRIN, "%DATA18%", K_DATA18) STRIN = Replace(STRIN, "%DATA19%", K_DATA19) STRIN = Replace(STRIN, "%DATA20%", K_DATA20) STRIN = Replace(STRIN, "%DATA21%", K_DATA21) STRIN = Replace(STRIN, "%DATA22%", K_DATA22) STRIN = Replace(STRIN, "%DATA23%", K_DATA23) STRIN = Replace(STRIN, "%DATA24%", K_DATA24) STRIN = Replace(STRIN, "%DATA25%", K_DATA25) STRIN = Replace(STRIN, "%DATA26%", K_DATA26) STRIN = Replace(STRIN, "%DATA27%", K_DATA27) STRIN = Replace(STRIN, "%DATA28%", K_DATA28) STRIN = Replace(STRIN, "%DATA29%", K_DATA29) STRIN = Replace(STRIN, "%DATA30%", K_DATA30) STRIN = Replace(STRIN, "%DATA31%", K_DATA31) STRIN = Replace(STRIN, "%DATA32%", K_DATA32) STRIN = Replace(STRIN, "%DATA33%", K_DATA33) STRIN = Replace(STRIN, "%DATA34%", K_DATA34) STRIN = Replace(STRIN, "%DATA35%", K_DATA35) STRIN = Replace(STRIN, "%DATA36%", K_DATA36) STRIN = Replace(STRIN, "%DATA37%", K_DATA37) STRIN = Replace(STRIN, "%DATA38%", K_DATA38) STRIN = Replace(STRIN, "%DATA39%", K_DATA39) STRIN = Replace(STRIN, "%DATA40%", K_DATA40) DataReplace = STRIN End Function Sub GenerateTestScripts() StartConfRow = 6 SumRow = 6 max_rows = 1500 strFileName = "C:\t\out.xls" saveFrequency = 200 Set oBook = Application.Workbooks.Open(strFileName) Set AllSheets = oBook.Sheets("ALL") Set BaseSheet = oBook.Sheets("BASE") Set confSheet = oBook.Sheets("KONF") Set SumSheet = oBook.Sheets("SUMMARY") For i = 3 To max_rows If i Mod saveFrequency = 0 Then oBook.Close SaveChanges:=True Set oBook = Nothing Set AllSheets = Nothing Set BaseSheet = Nothing Set confSheet = Nothing Set SumSheet = Nothing Set NewSheet = Nothing Set oBook = Application.Workbooks.Open(strFileName) Set AllSheets = oBook.Sheets("ALL") Set BaseSheet = oBook.Sheets("BASE") Set confSheet = oBook.Sheets("KONF") Set SumSheet = oBook.Sheets("SUMMARY") End If If (AllSheets.Range("B" + CStr(i)).Value = 1) Then TC_ID = AllSheets.Range("K" + CStr(i)).Value ' get configurations j = i + 1 While (AllSheets.Range("C" + CStr(j)).Value = 1) KO_ID = oBook.Sheets("ALL").Range("N" + CStr(j)).Value 'get configuration k = StartConfRow While ((confSheet.Range("B" + CStr(k)).Value < "") And (confSheet.Range("B" + CStr(k)) < KO_ID)) k = k + 1 Wend 'check if found or end If (confSheet.Range("B" + CStr(k)).Value = KO_ID) Then K_DATA0 = confSheet.Range("C" + CStr(k)).Value K_DATA1 = confSheet.Range("D" + CStr(k)).Value K_DATA2 = confSheet.Range("E" + CStr(k)).Value K_DATA3 = confSheet.Range("F" + CStr(k)).Value K_DATA4 = confSheet.Range("G" + CStr(k)).Value K_DATA5 = confSheet.Range("H" + CStr(k)).Value K_DATA6 = confSheet.Range("I" + CStr(k)).Value K_DATA7 = confSheet.Range("J" + CStr(k)).Value K_DATA8 = confSheet.Range("K" + CStr(k)).Value K_DATA9 = confSheet.Range("L" + CStr(k)).Value K_DATA10 = confSheet.Range("M" + CStr(k)).Value K_DATA11 = confSheet.Range("N" + CStr(k)).Value K_DATA12 = confSheet.Range("O" + CStr(k)).Value K_DATA13 = confSheet.Range("P" + CStr(k)).Value K_DATA14 = confSheet.Range("Q" + CStr(k)).Value K_DATA15 = confSheet.Range("R" + CStr(k)).Value K_DATA16 = confSheet.Range("S" + CStr(k)).Value K_DATA17 = confSheet.Range("T" + CStr(k)).Value K_DATA18 = confSheet.Range("U" + CStr(k)).Value K_DATA19 = confSheet.Range("V" + CStr(k)).Value K_DATA20 = confSheet.Range("W" + CStr(k)).Value K_DATA21 = confSheet.Range("X" + CStr(k)).Value K_DATA22 = confSheet.Range("Y" + CStr(k)).Value K_DATA23 = confSheet.Range("Z" + CStr(k)).Value K_DATA24 = confSheet.Range("AA" + CStr(k)).Value K_DATA25 = confSheet.Range("AB" + CStr(k)).Value K_DATA26 = confSheet.Range("AC" + CStr(k)).Value K_DATA27 = confSheet.Range("AD" + CStr(k)).Value K_DATA28 = confSheet.Range("AE" + CStr(k)).Value K_DATA29 = confSheet.Range("AF" + CStr(k)).Value K_DATA30 = confSheet.Range("AG" + CStr(k)).Value K_DATA31 = confSheet.Range("AH" + CStr(k)).Value K_DATA32 = confSheet.Range("AI" + CStr(k)).Value K_DATA33 = confSheet.Range("AJ" + CStr(k)).Value K_DATA34 = confSheet.Range("AK" + CStr(k)).Value K_DATA35 = confSheet.Range("AL" + CStr(k)).Value K_DATA36 = confSheet.Range("AM" + CStr(k)).Value K_DATA37 = confSheet.Range("AN" + CStr(k)).Value K_DATA38 = confSheet.Range("AO" + CStr(k)).Value K_DATA39 = confSheet.Range("AP" + CStr(k)).Value K_DATA40 = confSheet.Range("AR" + CStr(k)).Value K_TESTER = confSheet.Range("A" + CStr(k)).Value TC_TITLE = DataReplace(AllSheets.Range("L" + CStr(i)).Value) TC_DESC = DataReplace(AllSheets.Range("M" + CStr(i)).Value) BaseSheet.Copy Befo=oBook.Sheets(1) Set NewSheet = oBook.Sheets(1) NewSheet.Name = TC_ID + "_" + KO_ID NewSheet.Range("C1:M1").Value = TC_ID NewSheet.Range("C2:M2").Value = KO_ID NewSheet.Range("C3:M3").Value = TC_TITLE NewSheet.Range("B6:M6").Value = TC_DESC 'get WK l = j + 1 rowWK = 12 rowPrev = 9 rowCase = 15 rowSum = 19 firstCaseRow = 15 While ((AllSheets.Range("B" + CStr(l)).Value < "1") And (l < max_rows)) ' WK If (AllSheets.Range("D" + CStr(l)).Value = "1") Then WK = DataReplace(AllSheets.Range("O" + CStr(l)).Value) NewSheet.Range("B" + CStr(rowWK) + ":M" + CStr(rowWK)).Value = WK End If ' PREV If (AllSheets.Range("E" + CStr(l)).Value = "1") Then NewSheet.Rows(CStr(rowPrev) + ":" + CStr(rowPrev)).Copy NewSheet.Rows(CStr(rowPrev) + ":" + CStr(rowPrev)).Insert Shift:=xlDown Application.CutCopyMode = False NewSheet.Range("B" + CStr(rowPrev) + ":D" + CStr(rowPrev)).Value = AllSheets.Range("P" + CStr(l)).Value rowPrev = rowPrev + 1 rowWK = rowWK + 1 rowCase = rowCase + 1 firstCaseRow = firstCaseRow + 1 rowSum = rowSum + 1 End If ' CASE STEP If (AllSheets.Range("G" + CStr(l)).Value = "1") Then NewSheet.Rows(CStr(rowCase + 1) + ":" + CStr(rowCase + 1)).Copy NewSheet.Rows(CStr(rowCase + 1) + ":" + CStr(rowCase + 1)).Insert Shift:=xlDown Application.CutCopyMode = False strId = DataReplace(AllSheets.Range("R" + CStr(l)).Value) strTitle = DataReplace(AllSheets.Range("S" + CStr(l)).Value) strDesc = DataReplace(AllSheets.Range("T" + CStr(l)).Value) strResult = DataReplace(AllSheets.Range("U" + CStr(l)).Value) NewSheet.Range("A" + CStr(rowCase)).Value = strId NewSheet.Range("B" + CStr(rowCase)).Value = strTitle NewSheet.Range("C" + CStr(rowCase) + ":G" + CStr(rowCase)).Value = strDesc NewSheet.Range("H" + CStr(rowCase) + ":J" + CStr(rowCase)).Value = strResult If (AllSheets.Range("W" + CStr(l)).Value = "1") Then NewSheet.Range("K" + CStr(rowCase)).Value = "OK." NewSheet.Range("N" + CStr(rowCase)).Value = 1 End If numlines = SF_countLines(strId) numlines = Application.WorksheetFunction.Max(numlines, SF_countLines(strTitle)) numlines = Application.WorksheetFunction.Max(numlines, SF_countLines(strDesc)) numlines = Application.WorksheetFunction.Max(numlines, SF_countLines(strResult)) rowHeightMin = 24 rowHeightLine = 11.25 RowHeight = Application.WorksheetFunction.Max((numlines + 1) * rowHeightLine, rowHeightMin) NewSheet.Rows(CStr(rowCase) + ":" + CStr(rowCase)).RowHeight = RowHeight 'if always ok rowCase = rowCase + 1 rowSum = rowSum + 1 End If l = l + 1 Wend NewSheet.Rows(CStr(rowPrev) + ":" + CStr(rowPrev)).Delete Shift:=xlUp rowCase = rowCase - 1 firstCaseRow = firstCaseRow - 1 rowSum = rowSum - 1 NewSheet.Rows(CStr(rowCase + 1) + ":" + CStr(rowCase)).Delete Shift:=xlUp rowSum = rowSum - 2 Application.CutCopyMode = False 'copy next do summary SumSheet.Activate SumSheet.Rows(CStr(SumRow + 1) + ":" + CStr(SumRow + 1)).Copy SumSheet.Rows(CStr(SumRow + 1) + ":" + CStr(SumRow + 1)).Insert Shift:=xlDown Application.CutCopyMode = False ' SumSheet.Range("A" + CStr(SumRow)).Value = K_TESTER SumSheet.Range("B" + CStr(SumRow)).Value = TC_ID SumSheet.Range("C" + CStr(SumRow)).Value = KO_ID SumSheet.Range("D" + CStr(SumRow)).Value = TC_TITLE SumSheet.Hyperlinks.Add Anchor:=SumSheet.Range("B" + CStr(SumRow) + ":D" + CStr(SumRow)), Address:="", SubAddress:="'" + NewSheet.Name + "'!K" + CStr(firstCaseRow), TextToDisplay:=TC_ID SumSheet.Range("E" + CStr(SumRow)).Formula = "='" + NewSheet.Name + "'!C" + CStr(rowSum) SumSheet.Range("F" + CStr(SumRow)).Formula = "='" + NewSheet.Name + "'!C" + CStr(rowSum + 1) SumSheet.Range("G" + CStr(SumRow)).Formula = "='" + NewSheet.Name + "'!C" + CStr(rowSum + 2) SumSheet.Range("H" + CStr(SumRow)).Formula = "='" + NewSheet.Name + "'!C" + CStr(rowSum + 3) SumSheet.Range("I" + CStr(SumRow)).Formula = "='" + NewSheet.Name + "'!C" + CStr(rowSum + 4) SumSheet.Range("J" + CStr(SumRow)).Formula = "='" + NewSheet.Name + "'!C" + CStr(rowSum + 5) SumSheet.Range("K" + CStr(SumRow)).Formula = "='" + NewSheet.Name + "'!C" + CStr(rowSum + 6) NewSheet.Activate NewSheet.Hyperlinks.Add Anchor:=NewSheet.Range("B" + CStr(rowSum + 8)), Address:="", SubAddress:="'" + SumSheet.Name + "'!D" + CStr(SumRow), TextToDisplay:="<<PODSUMOWANIE" NewSheet.Range("K" + CStr(firstCaseRow)).Select SumRow = SumRow + 1 'Protect Sheet NewSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True NewSheet.EnableSelection = xlUnlockedCells j = j + 1 End If Wend End If Next i SumSheet.Activate SumSheet.Rows(CStr(rowSum + 1) + ":" + CStr(rowSum)).Delete Shift:=xlUp End Sub |
The object invoked as disconnected from its clients. - To many she
Anybody?
It's quite important for me... |
All times are GMT +1. The time now is 12:44 AM. |
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
ExcelBanter.com