how to insert a data in sheet witout overwrite the macro

[kimtun]

dear all:
i have a program that build with a marco on that file, may i know everytime when i run to update the data, may i know how
can i "insert" the data on the sheet rather then overwrite it, it is because when everytime i execute the program, the marco i write in a module will be overwrite, following in the code


Private Sub cmdStart_Click()
Dim Excel As Object
Dim elem As Object
Dim excelSheet As Object
Dim Array1 As Variant
Dim Count, RowNum As Integer
Dim NumberOfAttributes As Integer
Dim foundAttributes As Boolean

' Start Excel
On Error Resume Next

' See if this drawing contains any attribute information
For Each elem In ThisDrawing.ModelSpace
If elem.EntityName = "AcDbBlockReference" Then
If elem.HasAttributes Then
foundAttributes = True
Exit For
End If
End If
Next

' If no attributes were found then exit
If Not foundAttributes Then
MsgBox "No attributes found in the current drawing.", vbInformation
Exit Sub
End If

' Load Excel
'Set Excel = GetObject(, "Excel.Application")
Set Excel = GetObject("c:\excel\bool.XLS", "Excel.Application")


If Err <> 0 Then
Err.Clear
Set Excel = CreateObject("Excel.Application")

If Err <> 0 Then
MsgBox "Could not load Excel.", vbExclamation
End
End If
End If

On Error GoTo 0

Excel.Visible = True
Excel.Workbooks.Add
Excel.Sheets("Sheet1").Select
Set excelSheet = Excel.ActiveWorkbook.Sheets("Sheet1")

RowNum = 1
Dim Header As Boolean
For Each elem In ThisDrawing.ModelSpace
If elem.EntityName = "AcDbBlockReference" Then
If elem.HasAttributes Then
Array1 = elem.GetAttributes
For Count = LBound(Array1) To UBound(Array1)
If Header = False Then
If (Array1(Count).EntityName) = "AcDbAttribute" Then
excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TagString
End If
End If
Next Count
RowNum = RowNum + 1
For Count = LBound(Array1) To UBound(Array1)
excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TextString
Next Count
Header = True
End If
End If
Next elem
'excelSheet.Insert.
NumberOfAttributes = RowNum - 1

excelSheet.SaveAs "C:\excel\bool.xls"
Unload Me
End Sub

 

[Joe Was]

Private Sub cmdStart_Click()
Dim Excel As Object
Dim elem As Object
Dim excelSheet As Object
Dim Array1 As Variant
Dim Count, RowNum As Integer
Dim NumberOfAttributes As Integer
Dim foundAttributes As Boolean

' Start Excel
On Error Resume Next

' See if this drawing contains any attribute information
For Each elem In ThisDrawing.ModelSpace
If elem.EntityName = "AcDbBlockReference" Then
If elem.HasAttributes Then
foundAttributes = True
Exit For
End If
End If
Next

' If no attributes were found then exit
If Not foundAttributes Then
MsgBox "No attributes found in the current drawing.", vbInformation
Exit Sub
End If

' Load Excel
'Set Excel = GetObject(, "Excel.Application")
Set Excel = GetObject("c:\excel\bool.XLS", "Excel.Application")


If Err <> 0 Then
Err.Clear
Set Excel = CreateObject("Excel.Application")

If Err <> 0 Then
MsgBox "Could not load Excel.", vbExclamation
End
End If
End If

On Error GoTo 0

Excel.Visible = True
Excel.Workbooks.Add
Excel.Sheets("Sheet1").Select
Set excelSheet = Excel.ActiveWorkbook.Sheets("Sheet1")


'RowNum = 1

RowNum = ActiveSheet.Range("A65536").End(xlUp).OffSet(2,0).Row


Dim Header As Boolean
For Each elem In ThisDrawing.ModelSpace
If elem.EntityName = "AcDbBlockReference" Then
If elem.HasAttributes Then
Array1 = elem.GetAttributes
For Count = LBound(Array1) To UBound(Array1)
If Header = False Then
If (Array1(Count).EntityName) = "AcDbAttribute" Then
excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TagString
End If
End If
Next Count
RowNum = RowNum + 1
For Count = LBound(Array1) To UBound(Array1)
excelSheet.Cells(RowNum, Count + 1).Value = Array1(Count).TextString
Next Count
Header = True
End If
End If
Next elem
'excelSheet.Insert.
NumberOfAttributes = RowNum - 1

excelSheet.SaveAs "C:\excel\bool.xls"
Unload Me
End Sub

 

[kimtun]

the result still same, bec the marco be overwrite also, anyway thx