Jump to content
Elias

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

Recommended Posts

Elias

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

Share this post


Link to post
Share on other sites
rlx

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

Share this post


Link to post
Share on other sites
BIGAL

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

  • Thanks 1

Share this post


Link to post
Share on other sites
Elias
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    

Share this post


Link to post
Share on other sites
BIGAL

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

Share this post


Link to post
Share on other sites
Elias

 Sorry for disturbing you 

 

 

 TEST.xlsm

 

 

 

 

2020-09-24_013905.thumb.jpg.6b422dd7605f752583b0cba819e760e7.jpg

Share this post


Link to post
Share on other sites
BIGAL

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

Share this post


Link to post
Share on other sites
sanju2323

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

Share this post


Link to post
Share on other sites
Elias

Your solution was very helpful, truly Bro you are a genius 
Thanks a lot

Share this post


Link to post
Share on other sites
sanju2323

Your welcome 🙂

  • Like 1

Share this post


Link to post
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
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  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...