Jump to content

I faced problem with VBA code, I want to start numbering as 1 from the third cell but it's started from number 2 ?!


Elias

Recommended Posts

Sub XYZ()
Dim ttt1 As String
Dim ttt2 As String
Dim ttt3 As String
Dim ccoc As Integer
Dim P1(0 To 2) As Double
Dim t1 As Variant
Dim t2 As Variant
Dim total(0 To 5) As Double
Dim t, sel, myBlock, po, ac, b1, b2, xl As Object
Dim p As Variant
Dim p2(0 To 2) As Double
Dim tex, i, ch, c, g, r, tp, en, co, rn
On Error Resume Next
Set ac = GetObject(, "AutoCAD.Application"): Set xl = GetObject(, "Excel.Application")
If Err <> 0 Then MsgBox "Please you should open AutoCAD first  :(": Exit Sub
xl.WindowState = xlMinimized
ac.WindowState = vbMaximizedFocus
On Error Resume Next: ac.ActiveDocument.SelectionSets("TempSSet").Delete
Set sel = ac.ActiveDocument.SelectionSets.Add("TempSSet")
sel.SelectOnScreen

i = -1: Cells(0, 1) = "SNo.": Cells(1, 2) = "EASTING": Cells(1, 3) = "NORTHING": Cells(1, 4) = "ELEVATION": Cells(1, 5) = "Object Name": Cells(1, 6) = "Length": Cells(1, 7) = "Radius": Cells(1, 8.) = "Area"
For Each po In sel
tp = tp + 1
Next
co = 2
rn = 3
If Sheet62.CheckBox1.Value = False Or Sheet62.CheckBox2.Value = False Then xl.WindowState = xlMaximized
For Each po In sel
If co = 8 Then co = 2 Else co = co + 1
i = i + 1
If i > tp - 1 Then Exit For
Set myBlock = sel.Item(i)
If InStr(1, myBlock.ObjectName, "Text", vbTextCompare) = False And InStr(1, myBlock.ObjectName, "Leader", vbTextCompare) = False And InStr(1, myBlock.ObjectName, "Dimension", vbTextCompare) = False Then
If myBlock.ObjectName = "AcDbLine" Or myBlock.ObjectName = "AcDbArc" Then
t1 = myBlock.StartPoint
t2 = myBlock.EndPoint
total(0) = t1(0): total(1) = t1(1): total(2) = t1(2): total(3) = t2(0): total(4) = t2(1): total(5) = t2(2)
p = total
Else
p = myBlock.Coordinates
End If
If myBlock.ObjectName = "AcDbCircle" Then
p = myBlock.Center
End If
On Error Resume Next
For g = 0 To 100000
Err.Clear
ch = p(g)
If Err <> 0 Then Exit For
Next
g = g - 1
If myBlock.ObjectName = "AcDbPolyline" Or myBlock.ObjectName = "AcDbSpline" Then r = 2 Else r = 3
en = 0
For c = 0 To g Step r
P1(0) = p(c): P1(1) = p(c + 1)
If r = 3 Then P1(2) = p(c + 2)
jeenee = myBlock.ObjectName
If Left(jeenee, 4) = "AcDb" Then jeenee = ExtractElement(jeenee, 2, "AcDb")
For nee = 1 To rn - 1
If Cells(nee, 2).Value = P1(0) And Cells(nee, 3).Value = P1(1) Then Exit For
Next
p2(0) = P1(0) + Sheet62.TextBox2.Text: p2(1) = P1(1) + Sheet62.TextBox3.Text: p2(2) = 0: Cells(rn, 2) = rn - 1: Cells(rn, 3) = P1(0): Cells(rn, 4) = P1(1): Cells(rn, 5) = P1(2): Cells(rn, 6) = jeenee
tex = ""
ccoc = Sheet62.TextBox4.Text
ttt1 = Round(P1(0), ccoc)
ttt1 = Cunt(ttt1, ccoc)
ttt2 = Round(P1(1), ccoc)
ttt2 = Cunt(ttt2, ccoc)
ttt3 = Round(P1(2), ccoc)
ttt3 = Cunt(ttt3, ccoc)

If Sheet62.CheckBox1.Value = True Then tex = "X = " & ttt1 & Chr(10) & "Y = " & ttt2 & Chr(10) & "Z = " & ttt3 & Chr(10)
If Sheet62.CheckBox2.Value = True Then tex = "P. " & rn - 1 & Chr(10) & tex
If Sheet62.CheckBox6.Value = True Then tex = rn - 1 & Chr(10) & tex
If nee = rn And (Sheet62.CheckBox1.Value = True Or Sheet62.CheckBox2.Value = True Or Sheet62.CheckBox6.Value = True) Then Set t = ac.ActiveDocument.ModelSpace.AddMText(p2, 0, tex): t.Height = Sheet62.TextBox1.Text: t.Update

en = en + 1
rn = rn + 1
Next
'If myBlock.Layer = "" Then Cells(1, 8.)= 0 Else
If myBlock.ObjectName = "AcDbLine" Or myBlock.ObjectName = "AcDbPolyline" Then Cells(rn - 1, 7) = Round(myBlock.Length, 4)
If myBlock.ObjectName = "AcDbLine" Or myBlock.ObjectName = "AcDbPolyline" Then Cells(rn - 1, 9) = Round(myBlock.Area, 4)
If myBlock.ObjectName = "AcDbCircle" Or myBlock.ObjectName = "AcDbArc" Then Cells(rn - 1, 8.) = Round(myBlock.Radius, 4)
If myBlock.ObjectName = "AcDbCircle" Or myBlock.ObjectName = "AcDbArc" Then Cells(rn - 1, 9) = Round(myBlock.Area, 4)
End If
Next
Columns("A:I").EntireColumn.AutoFit
Columns("J:I").Font.Bold = True
 Range("A1:I1").Font.Bold = True
 Range("A1:I1").HorizontalAlignment = xlCenter
 
 
End Sub

Edited by Elias
Link to comment
Share on other sites

this site has a special vba forum , think you should post there. I have close to zero experience with vba so I gonna do a wild guess :


i = -1: Cells(0, 1) = "SNo.": Cells(1, 2) = "EASTING": Cells(1, 3) = "NORTHING": Cells(1, 4) = "ELEVATION": Cells(1, 5) = "Object Name": Cells(1, 6) = "Length": Cells(1, 7) = "Radius":

 

I assume i=-1 is a counter and you probably use ...bladiebla (set i (i +1))... at some point. In lisp the first item in a list is number 0 , but , just guessing here , maybe vba / excel starts with 1? I don't have vba enabled in my autocad so I can't test it. I'm sure other users here use vba , I believe Bigal has some experience with vba and he respons to many of the questions posted on this forum so I wouldn't be surpised he will give you a (better) answer.

 

 

  • Like 1
Link to comment
Share on other sites

9 hours ago, BIGAL said:

What I know about VBa is dangerous, some stuff missing to test maybe Cells(rn, 2) = rn - 1 rn-2 ?

Hello Dear BIGAL,

 

Can you please be more specific what is the missing stuff

when I put rn=2 it's start numbering from 1 in the second ROW so I need it to start numbering (1) from the third ROW, I tired a lot but I still don't know what was the mistake.

 Thanks    

Link to comment
Share on other sites

If you wrote the code then you should be able to work out what is wrong or did some one else do it ? It looks like some forms are being called. 

 

Ok

1 need image showing what is wrong. 

2 need xls with macro in it.

 

Again I am no expert in VBA.

  • Thanks 1
Link to comment
Share on other sites

As I already guessed look at your row numbers you have row 1 as a blank line so row3 -2 if want a 1. Its a case of finding that rn-2 position. Not sure why row 1 is blank but that may be harder to fix. Can test is A1 blank A2 blank etc and subtract correct row number.

 

I think its in this line

p2(0) = P1(0) + Sheet62.TextBox2.Text: p2(1) = P1(1) + Sheet62.TextBox3.Text: p2(2) = 0: Cells(rn, 2) = rn - 1: Cells(rn, 3) = P1(0): Cells(rn, 4) = P1(1): Cells(rn, 5) = P1(2):

 

not tested busy at moment

Edited by BIGAL
Link to comment
Share on other sites

Hi Elias,

 

   You need to change some lines below, hope your issue is resolved.


 

'Replace line

If Sheet1.CheckBox2.Value = True Then tex = "P. " & rn - 1 & Chr(10) & tex
If Sheet1.CheckBox6.Value = True Then tex = rn - 1 & Chr(10) & tex

'with

If Sheet1.CheckBox2.Value = True Then tex = "P. " & rn - 2 & Chr(10) & tex
If Sheet1.CheckBox6.Value = True Then tex = rn - 2 & Chr(10) & tex
'Replace line

p2(0) = P1(0) + Sheet1.TextBox2.Text: p2(1) = P1(1) + Sheet1.TextBox3.Text: p2(2) = 0: Cells(rn, 2) = rn - 1: Cells(rn, 3) = P1(0): Cells(rn, 4) = P1(1): Cells(rn, 5) = P1(2): Cells(rn, 6) = jeenee

'with

p2(0) = P1(0) + Sheet1.TextBox2.Text: p2(1) = P1(1) + Sheet1.TextBox3.Text: p2(2) = 0: Cells(rn, 2) = rn - 2: Cells(rn, 3) = P1(0): Cells(rn, 4) = P1(1): Cells(rn, 5) = P1(2): Cells(rn, 6) = jeenee

 

Bye

Edited by sanju2323
  • Thanks 1
Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...