The purpose is to take attribute information and concatenate those into 1 column titled "Description", and then have the drawing number attribute fill the second column titled "Drawing No.".
For ease of use in the Drawing index Table that is in AutoCAD, I also have blank rows and underlined Subheadings in the Parent Workbook which I add as required.
As an example, CROSS SECTIONS, would be manually added above a number of cross section drawings, then a blank row and underlined subheading of the next subcategory of Typical Details.
This is the new feature I was initially trying to add to the workbook, as previously it was just a spreadsheet to populate title blocks. The Drawing index had to be typed manually as MText in the drawing, and needed to be manually updated as the Drawing register changed.
I would like to be able to carry across the Underlined text and have the Table in AutoCAD have the text style of iso. Iso didn't seem to work, but isocp did. The Underlines are lost.
This is also just a copy and paste collage of code, that gave satisfactory results in achieving what I wanted to do.
For the Two weeks that it worked, I was pretty happy with what I had done as a VBA novice.
Obviously not good enough to put on the fridge, but IT IS my first attempt...
Sub SaveAsXLXS()
'
' export Macro
Dim wbS As Workbook, wbT As Workbook
Dim wsS As Worksheet, wsT As Worksheet
Set wbS = ThisWorkbook 'workbook that holds this code
Set wsS = wbS.Worksheets("DRAWING INDEX")
wsS.Copy
Set wbT = ActiveWorkbook 'assign reference asap
Set wsT = wbT.Worksheets("DRAWING INDEX")
wsT.Name = "DRAWING INDEX" 'rename sheet
MsgBox wbS.path, , "PATH"
'Test to see if the folder path exists.
Dim FolderPath As String
FolderPath = wbS.path
If Right(FolderPath, 1)"\" Then
FolderPath = FolderPath & "\"
End If
If Dir(FolderPath, vbDirectory)vbNullString Then
MsgBox "Folder exists"
Else
MsgBox "Folder doesn't exist"
End If
'test if file exists
Dim filePath As String
Dim TestStr As String
filePath = wbS.path & "\DRAWING INDEX.xlsx"
MsgBox filePath, , "FILE PATH"
TestStr = ""
On Error Resume Next
TestStr = Dir(filePath)
MsgBox TestStr & "String Empty", , "Test string equals " & TestStr
On Error GoTo 0
If TestStr = "" Then
MsgBox "File doesn't exist", , "String Empty"
Else
MsgBox "File exist", , "TestStr = " & TestStr
End If
'Test if file is open
MsgBox "Is Drawing Open?", vbOKOnly, "TEST"
If bIsBookOpen("DRAWING INDEX.xlsx") Then
MsgBox ("DRAWING INDEX.xlsx is open!" & chr13 + "CLOSE THE SPREADSHEET and TRY AGAIN"), , "DRAWING INDEX IS OPEN"
ActiveWorkbook.Close SaveChanges:=False
Exit Sub
Else
MsgBox "The Book is not open!", , "DRAWING INDEX IS NOT OPEN"
End If
'save new workbook
wbT.SaveAs filename:=wbS.path & "\DRAWING INDEX", FileFormat:=51, CreateBackup:=False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'MsgBox ActiveWorkbook.FullName
'MsgBox ActiveWorkbook.Path
Sheets("DRAWING INDEX").Select
Range("A2:B2").Select
Selection.UnMerge
Range("A3").Select
activecell.FormulaR1C1 = "DESCRIPTION"
Selection.Font.Underline = xlUnderlineStyleSingle
Range("B3").Select
activecell.FormulaR1C1 = "DRAWING No."
Selection.Font.Underline = xlUnderlineStyleSingle
Range("A2").Select
activecell.FormulaR1C1 = "DRAWING INDEX"
Selection.Font.Underline = xlUnderlineStyleSingle
'
' DELETE BUTTON
'
ActiveSheet.Shapes.Range(Array("Button 1")).Select
Selection.DELETE
' DELETE ROW 1
Rows("1:1").Select
Selection.DELETE Shift:=xlUp
' SAVE AND CLOSE
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.DisplayAlerts = False
Application.ScreenUpdating = False
' MESSAGE BOX
strName = wbS.path & "\DRAWING INDEX.xlsx"
MsgBox "File has been Created and Saved as:" & vbCr & strName, , "COPY & SAVE REPORT"
End Sub
Sub CommandButton2_Click()
'CLEAR DRAWING INDEX
Sheets("DRAWING INDEX").Select
' resize_page Macro
'
Cells.Select
Selection.ClearContents
Selection.ClearFormats
Cells.Select
Selection.RowHeight = 15
Cells.Select
Selection.ColumnWidth = 8
Selection.UnMerge
Range("A1").Select
'SELECT MRWA SHEET
Sheets("MRWA").Select
Range("F4:F100,E4:E100,C4:C100").Copy Destination:=Worksheets("Drawing Index").Range("A4")
Sheets("Drawing Index").Range("A4:A100").Copy Destination:=Worksheets("Drawing Index").Range("E4")
Sheets("Drawing Index").Range("C4:C100").Cut Destination:=Worksheets("Drawing Index").Range("A4")
Sheets("Drawing Index").Range("A2").Value = "DRAWING INDEX"
'Selection.Font.UNDERLINE = xlUnderlineStyleSingle
Sheets("Drawing Index").Range("A3").Value = "DESCRIPTION"
'Selection.Font.UNDERLINE = xlUnderlineStyleSingle
Sheets("Drawing Index").Range("E3").Value = "DRAWING No."
'Selection.Font.UNDERLINE = xlUnderlineStyleSingle
Sheets("Drawing Index").Select
Range("A3").Select
'ActiveCell.FormulaR1C1 = "DESCRIPTION"
Selection.Font.Underline = xlUnderlineStyleSingle
Range("E3").Select
'ActiveCell.FormulaR1C1 = "DRAWING No."
Selection.Font.Underline = xlUnderlineStyleSingle
Range("A2").Select
'ActiveCell.FormulaR1C1 = "DRAWING INDEX"
Selection.Font.Underline = xlUnderlineStyleSingle
Sheets("Drawing Index").Select
Range("A:C").EntireColumn.AutoFit
Call CONCAT3
Call COPYPASTE
Call resize
Call MERGEDEL
Call SaveAsXLXS
End Sub
Sub CONCAT3()
' Insert column
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
''CONCATANATION
With Range("A100", Range("A" & Rows.Count).End(xlUp))
.Offset(, 0).FormulaR1C1 = "=ConcatenateRange(RC:RC,"" - "" )"
End With
End Sub
Sub COPYPASTE()
'
' COPYPASTE Macro
Range("A4:A100").Select
Selection.Copy
Range("B4:B100").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("A:A").Select
Application.CutCopyMode = False
Selection.DELETE Shift:=xlToLeft
Columns("E:E").Select
Selection.Cut
Columns("B:B").Select
ActiveSheet.Paste
Columns("B:B").EntireColumn.AutoFit
Columns("A:A").EntireColumn.AutoFit
End Sub
Sub MERGEDEL()
' MERGEDEL Macro
Range("A2:B2").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.MERGE
Range("A1:B1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.MERGE
Range("B3:B100").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Selection.MERGE True
End Sub
Function ConcatenateRange(Parts As Range, Separator As String) ' Build a single string from a passed range with a
' passed separator between each value
Dim strTemp As String, sepTemp As String
' declare strTemp and sepTemp as Strings. A String is a data type.
Dim Cell As Range
' declares cell as variable to store a cell reference
Dim cnt As Integer
' declares variable cnt and stores result as an Integer value
strTemp = ""
' defines the String strTemp as blank
For Each Cell In Parts.Cells
If Cell.Value = "" Or Cell.Value = 0 Then
' If value of cell is blank or = 0
sepTemp = ""
' the variable sepTemp will be stored as blank
Else
'If value of cell is not blank or = 0
sepTemp = Separator
' the variable sepTemp will store the separator defined by the user
End If
If Len(strTemp) = 0 Then
' if the length of the variable stored in strTemp = 0
strTemp = CStr(Cell.Value)
' the variable strTemp will be equal to the value of the current cell.
Else
' if the stored variable strTemp is not equal to 0
strTemp = strTemp & sepTemp & CStr(Cell.Value)
' the variable strTemp will equal the current cell value and concatenate with the user defined separator
End If
Next Cell
ConcatenateRange = strTemp
End Function
Sub resize()
'
' text_style Macro
'
'
Columns("A:A").Select
With Selection.Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
With Selection
.HorizontalAlignment = xlLeft
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
Range("A2:B2").Select
With Selection.Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
' resize Macro
'
'
Rows("1:100").Select
Selection.RowHeight = 15
Range("A3").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("B4:B99").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
' autofit
Range("A3:B100").Select
Selection.Columns.AutoFit
Rows("1:1").Select
Selection.RowHeight = 40
Rows("2:2").Select
Selection.RowHeight = 20
Rows("3:3").Select
Selection.RowHeight = 18
Rows("4:99").Select
Selection.RowHeight = 15
Columns("C:F").Select
Selection.Columns.AutoFit
Columns("C:C").Select
Selection.ColumnWidth = 8
ActiveWindow.Zoom = 100
End Sub I was thinking this morning whether the encoding format may have changed, and if so, what effect could it have?
What is the best format to use? Unicode, UTF8, UTF7, UTF16, UTF32, ASCII, or ANSI?
I'm assuming ASCII?
Something may have been saved in UTF8, or maybe cutting and pasting from the internet has included some hidden characters perhaps?
How can I check, and correct any issues relating to this?
What is best practice?
页:
1
[2]