Alphanumeric ordering of columns from Access Database

D

demo

I am automating a Bill of Materials within a window in a Visio drawing. This
all works pretty well. I would now like to sort the columns in an
alphanumeric(AN) order. Furthermore I would really like to have a certain
material row first on the list and then go to AN listing if this is possible.
I am getting my list from Access. Thanks.

IE:

EN001
EN002
AC032
DC004
HB067
M0004

Thanks,

PS: This is my code.

Dim details, details2, details3, details4, details5 As String
Dim description, description2, description3, description4, description5 As
String
Dim manufacture, manufacture2, manufacture3, manufacture4, manufacture5 As
String
Dim vendor, vendor2, vendor3, vendor4, vendor5 As String
Dim part, part2, part3, part4, part5 As String
Dim nappy, nappy2, nappy3, nappy4, nappy5 As String
Dim CellObj As Visio.Cell

Public Sub identifytag()

Dim shpobjtag, shpobjtag2, shpobjtag3, shpobjtag4 As Visio.shape
Dim iterate, iterate2, iterate3, iterate4 As Double
Dim shpsobjtag, shpsobjtag2, shpsobjtag3, shpsobjtag4 As Visio.shapes
Dim selection As Visio.selection

iterate = 1
iterate2 = 1
iterate3 = 1
iterate4 = 1

Set selection = ThisDocument.Application.ActiveWindow.selection

Do Until iterate > selection.Count
Set shpobjtag = selection.Item(iterate)

If shpobjtag.Name = "tag" Or shpobjtag.Name = "Tag" Or
shpobjtag.Name = "TAG" Then
On Error Resume Next
Set CellObj = shpobjtag.Cells("Prop.Tag1.value")
nappy = CellObj.ResultStr(Visio.visNone)
Set CellObj = Nothing
Set CellObj = shpobjtag.Cells("Prop.Tag2.value")
nappy2 = CellObj.ResultStr(Visio.visNone)
Set CellObj = Nothing
Set CellObj = shpobjtag.Cells("Prop.Tag3.value")
nappy3 = CellObj.ResultStr(Visio.visNone)
Set CellObj = Nothing
Set CellObj = shpobjtag.Cells("Prop.Tag4.value")
nappy4 = CellObj.ResultStr(Visio.visNone)
Set CellObj = Nothing
Set CellObj = shpobjtag.Cells("Prop.Tag5.value")
nappy5 = CellObj.ResultStr(Visio.visNone)
Set CellObj = Nothing


ElseIf shpobjtag.Type = 2 Then

Set shpsobjtag2 = shpobjtag.shapes



Do Until iterate2 > shpsobjtag2.Count
Set shpobjtag2 = shpsobjtag2.Item(iterate2)

If shpobjtag2.Name = "tag" Or shpobjtag2.Name = "Tag" Or
shpobjtag2.Name = "TAG" Then
Debug.Print shpobjtag2.Name
On Error Resume Next
On Error Resume Next
Set CellObj = shpobjtag2.Cells("User.Tag1.value")
nappy = CellObj.ResultStr(Visio.visNone)
Set CellObj = Nothing
Set CellObj = shpobjtag2.Cells("User.Tag2.value")
nappy2 = CellObj.ResultStr(Visio.visNone)
Set CellObj = Nothing
Set CellObj = shpobjtag2.Cells("User.Tag3.value")
nappy3 = CellObj.ResultStr(Visio.visNone)
Set CellObj = Nothing
Set CellObj = shpobjtag2.Cells("User.Tag4.value")
nappy4 = CellObj.ResultStr(Visio.visNone)
Set CellObj = Nothing
Set CellObj = shpobjtag2.Cells("User.Tag5.value")
nappy5 = CellObj.ResultStr(Visio.visNone)
Set CellObj = Nothing



ElseIf shpobjtag2.Type = 2 Then


Set shpsobjtag3 = shpobjtag2.shapes


Do Until iterate3 > shpsobjtag3.Count
Set shpobjtag3 = shpsobjtag3.Item(iterate3)

If shpobjtag3.Name = "tag" Or shpobjtag3.Name = "Tag" Or
shpobjtag3.Name = "TAG" Then
On Error Resume Next
Set CellObj = shpobjtag3.Cells("User.Tag1.value")
nappy = CellObj.ResultStr(Visio.visNone)
Set CellObj = Nothing
Set CellObj = shpobjtag3.Cells("User.Tag2.value")
nappy2 = CellObj.ResultStr(Visio.visNone)
Set CellObj = Nothing
Set CellObj = shpobjtag3.Cells("User.Tag3.value")
nappy3 = CellObj.ResultStr(Visio.visNone)
Set CellObj = Nothing
Set CellObj = shpobjtag3.Cells("User.Tag4.value")
nappy4 = CellObj.ResultStr(Visio.visNone)
Set CellObj = Nothing
Set CellObj = shpobjtag3.Cells("User.Tag5.value")
nappy5 = CellObj.ResultStr(Visio.visNone)
Set CellObj = Nothing

Debug.Print shpobjtag3.Name

ElseIf shpobjtag3.Type = 2 Then

Set shpsobjtag4 = shpobjtag3.shapes
Do Until iterate4 > shpsobjtag4.Count
Set shpobjtag4 = shpsobjtag4.Item(iterate4)

If shpobjtag4.Name = "tag" Or shpobjtag4.Name = "Tag" Or
shpobjtag4.Name = "TAG" Then
On Error Resume Next
Set CellObj = shpobjtag4.Cells("User.Tag1.value")
nappy = CellObj.ResultStr(Visio.visNone)
Set CellObj = Nothing
Set CellObj = shpobjtag4.Cells("User.Tag2.value")
nappy2 = CellObj.ResultStr(Visio.visNone)
Set CellObj = Nothing
Set CellObj = shpobjtag4.Cells("User.Tag3.value")
nappy3 = CellObj.ResultStr(Visio.visNone)
Set CellObj = Nothing
Set CellObj = shpobjtag4.Cells("User.Tag4.value")
nappy4 = CellObj.ResultStr(Visio.visNone)
Set CellObj = Nothing
Set CellObj = shpobjtag4.Cells("User.Tag5.value")
nappy5 = CellObj.ResultStr(Visio.visNone)
Set CellObj = Nothing



ElseIf shpobjtag4.Type = 2 Then


Set shpsobjtag4 = shpobjtag4.shapes
iterate4 = shpsobjtag4.Count


End If

iterate4 = iterate4 + 1
Loop


End If

iterate3 = iterate3 + 1
Loop


End If

iterate2 = iterate2 + 1
Loop


End If


iterate = iterate + 1

Loop


End Sub


Public Sub searchColumn()
On Error Resume Next
Dim varValues As Variant


If nappy = "" Or nappy = 0 Then
description = "No Information"
nappy = ""
Else
connect.rec.Index = (connect.column)
connect.rec.Seek "=", nappy


If connect.rec.NoMatch = True Then
If MsgBox("No Match For " & nappy & " In Access Database", vbOKOnly,
"Access Database Error") Then
End If


Else
varValues = connect.rec.GetRows

description = varValues(2, 0)

part = varValues(1, 0)
details = varValues(3, 0)

manufacture = varValues(4, 0)
vendor = varValues(5, 0)
End If
End If


End Sub

Public Sub searchColumn2()
On Error Resume Next
Dim varValues2 As Variant

If nappy2 = "" Or nappy2 = 0 Then
description2 = "No Information"
nappy2 = ""

Else
connect.rec.Index = (connect.column)
connect.rec.Seek "=", nappy2

If connect.rec.NoMatch = True Then
If MsgBox("No Match For " & nappy2 & " In Access Database", vbOKOnly,
"Access Database Error") Then
End If


Else
varValues2 = connect.rec.GetRows

description2 = varValues2(2, 0)

part2 = varValues2(1, 0)
details2 = varValues2(3, 0)

manufacture2 = varValues2(4, 0)
vendor2 = varValues2(5, 0)
End If
End If


End Sub
Public Sub searchColumn3()
On Error Resume Next
Dim varValues3 As Variant
If nappy3 = "" Or nappy3 = 0 Then
description3 = "No Information"
nappy3 = ""
Else

connect.rec.Index = (connect.column)
connect.rec.Seek "=", nappy3

If connect.rec.NoMatch = True Then
If MsgBox("No Match For " & nappy3 & " In Access Database", vbOKOnly,
"Access Database Error") Then
End If


Else
varValues3 = connect.rec.GetRows

description3 = varValues3(2, 0)

part3 = varValues3(1, 0)
details3 = varValues3(3, 0)

manufacture3 = varValues3(4, 0)
vendor3 = varValues3(5, 0)
End If


End If


End Sub

Public Sub searchColumn4()
On Error Resume Next
Dim varValues4 As Variant
If nappy4 = "" Or nappy4 = 0 Then
description4 = "No Information"
nappy4 = ""


Else
connect.rec.Index = (connect.column)
connect.rec.Seek "=", nappy4

If connect.rec.NoMatch = True Then
If MsgBox("No Match For " & nappy4 & " In Access Database", vbOKOnly,
"Access Database Error") Then
End If


Else
varValues4 = connect.rec.GetRows

description4 = varValues4(2, 0)

part4 = varValues4(1, 0)
details4 = varValues4(3, 0)

manufacture4 = varValues4(4, 0)
vendor4 = varValues4(5, 0)
End If
End If


End Sub
Public Sub searchColumn5()
On Error Resume Next

Dim varValues5 As Variant

If nappy5 = "" Or nappy5 = 0 Then


description5 = "No Information"
nappy5 = ""



Else

connect.rec.Index = (connect.column)
connect.rec.Seek "=", nappy5

If connect.rec.NoMatch = True Then
If MsgBox("No Match For " & nappy5 & " In Access Database", vbOKOnly,
"Access Database Error") Then
End If


Else
varValues5 = connect.rec.GetRows

description5 = varValues5(2, 0)

part5 = varValues5(1, 0)
details5 = varValues5(3, 0)

manufacture5 = varValues5(4, 0)
vendor5 = varValues5(5, 0)
End If
End If


End Sub

Private Sub cmdexit_Click()
End


End Sub


Private Sub Image2_Click()

End Sub

Private Sub lbldescription1_Click()

End Sub

Private Sub UserForm_Initialize()

Call identifytag
Call connect.Access
Call searchColumn
Call searchColumn2
Call searchColumn3
Call searchColumn4
Call searchColumn5
Call populate

End Sub

Public Sub populate()

Dim final, final2, final3, final4, final5 As String

lbltag1.Caption = nappy
final = part & " - " & description & " - " & details & " - " & manufacture &
" - " & vendor
lbldescription1.Caption = final


lbltag2.Caption = nappy2
final2 = part2 & " - " & description2 & " - " & details2 & " - " &
manufacture2 & " - " & vendor2
lbldescription2.Caption = final2

lbltag3.Caption = nappy3
final3 = part3 & " - " & description3 & " - " & details3 & " - " &
manufacture3 & " - " & vendor3
lbldescription3.Caption = final3


lbltag4.Caption = nappy4
final4 = part4 & " - " & description4 & " - " & details4 & " - " &
manufacture4 & " - " & vendor4
lbldescription4.Caption = final4


lbltag5.Caption = nappy5
final5 = part5 & " - " & description5 & " - " & details5 & " - " &
manufacture5 & " - " & vendor5
lbldescription5.Caption = final5
 
A

Al Edlund

this may be a silly question from the side, but why not have access sort it
out as part of the select for the recordset?
al
 
D

demo

Al, I thought about doing some sort of sort on the Access side. I tried some
stuff but nothing seemed to work on that side. I will look at it again.
Thanks,!
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

CellU and CellUExists not working for custom properties 3
Word macro that can call cells out of Excel for a find and replace 0
Working outlook via vba code with xlsx - error 0
VBA Coding Help for Beginner 0
Closing PDF file from Excel VBA (Adobe Reader, Adobe Acrobat, Browser) 0
AddPicturesToShapes 0
Help needed! Extracting Heading 3 and Contents from a Word Doc to Excel 0
VBA-Table Word 2019 - Move a selected text, from a cell to the adjacent cell to its right, by pressing the ENTER key 0

Top