G
Guest
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(Haystack1)
/ 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 Before:=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) + "
" +
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) + "" + 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
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(Haystack1)
/ 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 Before:=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) + "
" +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) + "
" + 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