API tools faq
paste
Advertisement
Guest User

Untitled

a guest
Jun 21st, 2018
70
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
VisualBasic 28.23 KB | None | 0 0
raw download clone embed print report
  1. Public strPrefix As String
  2. Sub SensorList()
  3. '
  4. ' SensorList Macro
  5. '
  6.  
  7.  
  8. '''''''''''''''''''''''''''''''''''''''''''' Pre filter start for moving door switch Start''''''''''''''''''''''''''''''''
  9.  
  10.   x = ActiveSheet.UsedRange.Rows.Count
  11.   y = 1
  12.   TotalRows = ActiveSheet.UsedRange.Rows.Count
  13.  
  14.     For x = TotalRows To 1 Step -1
  15.       If (InStr((Cells(x, 1).Value), "SR")) = 1 _
  16.             And InStr((Cells(x, 2).Value), "DS") = 1 _
  17.             And (InStr((Cells(x, 7).Value), "I")) = 1 Then
  18.                
  19.         Cells(x, (y + 1)).Select
  20.         Selection.Copy
  21.         Cells(x, y).Select
  22.         ActiveSheet.Paste
  23.         Application.CutCopyMode = False
  24.        
  25.        
  26.         Cells(x, (y + 2)).Select
  27.         Selection.Cut
  28.         Cells(x, (y + 1)).Select
  29.         ActiveSheet.Paste
  30.         Application.CutCopyMode = False
  31.        
  32.                Else
  33.                
  34.           End If
  35.      Next x
  36.      
  37.          
  38. '''''''''''''''''''''''''''''''''''''''''''Pre filter start for moving door switch End ''''''''''''''''''''''''''''
  39.  
  40.  
  41. ' Initialization
  42.  
  43.     GetPrefix
  44.    
  45.     InstList = Array("SENSORS", "HIGH VOLTAGE ELECTRICAL", "LOW VOLTAGE ELECTRICAL", "SAFETY") ' List of installation codes to be included in label file
  46.    FamilyList = Array("DS", "DISC", "LS", "PB", "PE", "PRS", "PRX", "PS", "LSR", "DV", "CB") ' List of family codes to be included in label file
  47.    Application.ScreenUpdating = False ' To avoid screen flicker.  Set to True before exiting macro.
  48.    
  49.     SearchOnInst = 0 ' Set to 0 to search on Family.  Set to 1 to search on Installation
  50.    
  51.     TotalRows = ActiveSheet.UsedRange.Rows.Count
  52.     TolalCols = ActiveSheet.UsedRange.Columns.Count
  53.     Tag = 0
  54.     Desc = Array(0, 0, 0, 0, 0) ' Allow up to five description fields
  55.    DescCount = 0
  56.     Addr = 0
  57.     Inst = 0
  58.  
  59. ' Locate Description Column Headers
  60.    For Col = 1 To 8 ' Max of eight columns to find
  61.        Head$ = ActiveSheet.Cells(1, Col).Value
  62.         If (InStr(1, Head$, "PLCDESC", 1)) > 0 Then
  63.             Desc(DescCount) = Col
  64.             DescCount = DescCount + 1
  65.         End If
  66.     Next Col
  67.  
  68. ' Eliminate crap columns that AutoCAD creates
  69.    Dim JunkRange As Range
  70.     Set JunkRange = ActiveSheet.Columns(DescCount + 4)
  71.     For Col = (DescCount + 5) To 214
  72.         Set JunkRange = Union(JunkRange, ActiveSheet.Columns(Col))
  73.     Next Col
  74.     JunkRange.Delete Shift:=xlToLeft
  75.    
  76.  
  77.     If DescCount > 2 Then
  78. ' Combine description columns into one
  79. '        For Row = 2 To TotalRows
  80. '            For DescIndex = 1 To DescCount - 1
  81. '                If Cells(Row, Desc(DescIndex)).Value <> "" Then
  82. '                    Cells(Row, Desc(0)).Value = Cells(Row, Desc(0)).Value + " " + Cells(Row, Desc(DescIndex)).Value
  83. '                End If
  84. '            Next DescIndex
  85. '        Next Row
  86. ' Remove extra description columns
  87.        For DescIndex = DescCount - 1 To 2 Step -1
  88.             Columns(Desc(DescIndex)).Delete Shift:=xlToLeft
  89.         Next DescIndex
  90.     End If
  91.    
  92. ' Locate remaining column headers
  93.    For Col = 1 To 8 ' Max of eight columns to find
  94.        Head$ = ActiveSheet.Cells(1, Col).Value
  95.         If Head$ = "CMPTAG" Then
  96.             Tag = Col
  97.         ElseIf Head$ = "PLCADDR" Then
  98.             Addr = Col
  99.         ElseIf Head$ = "CMPINST" Then
  100.             Inst = Col
  101.         End If
  102.     Next Col
  103.  
  104. ' Format remaining columns
  105.    ActiveSheet.Cells(1, Tag).Value = "TAG"
  106.     If DescCount > 0 Then
  107.         ActiveSheet.Cells(1, Desc(0)).Value = "DESC 1"
  108.     End If
  109.     If DescCount > 1 Then
  110.         ActiveSheet.Cells(1, Desc(1)).Value = "DESC 2"
  111.     End If
  112.     ActiveSheet.Cells(1, Addr).Value = "ADDRESS"
  113.     ActiveSheet.Rows(1).Font.Bold = True
  114.     For Col = 1 To (DescCount + 3)
  115.         ActiveSheet.Columns(Col).EntireColumn.AutoFit
  116.     Next Col
  117.  
  118.     If SearchOnInst = 1 Then
  119. ' Test INST column for filter
  120.        For Row = TotalRows To 2 Step -1
  121.             InstCode$ = ActiveSheet.Cells(Row, Inst).Value
  122.        
  123.             Keep = False
  124.        
  125.             For i = 0 To UBound(InstList)
  126.                 If InstCode$ = InstList(i) Then
  127.                     Keep = True
  128.                 End If
  129.             Next i
  130.        
  131.             If Not Keep Then
  132.                 Rows(Row).Delete
  133.             End If
  134.         Next Row
  135.     Else
  136. ' Test TAG column for filter
  137.        For Row = TotalRows To 2 Step -1
  138.             CurrentTag$ = ActiveSheet.Cells(Row, Tag).Value
  139.        
  140.             Keep = False
  141.        
  142.             For i = 0 To UBound(FamilyList)
  143.                 If (InStr(1, CurrentTag$, FamilyList(i), 1)) = 1 Then
  144.                     Keep = True
  145.                 End If
  146.             Next i
  147.        
  148.             If Not Keep Then
  149.                 Rows(Row).Delete
  150.             End If
  151.         Next Row
  152.     End If
  153.    
  154. ' Delete Installation code column - not wanted on labels
  155.    If (Inst > 0) Then
  156.         Columns(Inst).Delete
  157.     End If
  158.  
  159. ' Sort remaining entries based on first column
  160.    Columns("A:D").Select
  161.     Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, _
  162.         OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
  163. ' Sort format for Excel 2007
  164. '    Columns("A:C").Select
  165. '    ActiveSheet.Sort.SortFields.Clear
  166. '    ActiveSheet.Sort.SortFields.Add Key:= _
  167. '        Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
  168. '        xlSortNormal
  169. '    With ActiveSheet.Sort
  170. '        .SetRange ActiveSheet.UsedRange
  171. '        .Header = xlYes
  172. '        .MatchCase = False
  173. '        .Orientation = xlTopToBottom
  174. '        .SortMethod = xlPinYin
  175. '        .Apply
  176. '    End With
  177.    
  178.    
  179. ' ############### Remove duplicate tag rows
  180.  
  181.     Columns("D:D").Select
  182.     Selection.SpecialCells(xlCellTypeBlanks).Select
  183.     Selection.EntireRow.Delete
  184.    
  185.  ' ############### End of Remove duplicate tag rows
  186.    
  187. ' Move cursor
  188.    Application.ScreenUpdating = True
  189.     ActiveWindow.ScrollColumn = 1
  190.     Cells(1, 1).Select
  191.  
  192. ' Save as CSV file, preserving the original XLS file
  193. ' Prompt user for project number
  194.    On Error GoTo ErrorHandler
  195.         Path$ = ActiveWorkbook.Path
  196.         'MsgBox (Path$)
  197.        
  198.         DefaultNum$ = Left(ActiveWorkbook.Name, 5)
  199.         If Not (DefaultNum$ Like "[0-9][0-9][0-9][0-9][0-9]") Then
  200.             DefaultNum$ = ""
  201.         End If
  202.         ProjectNum$ = InputBox("Please enter the 5-digit project number:", "Project Number", DefaultNum$)
  203.         'GetPrefix
  204.        Filename$ = Path$ + "\" + ProjectNum$ + "_Labels_4Line_Sensors.txt"
  205.         ActiveWorkbook.SaveAs Filename:=Filename$, FileFormat:=xlCSV, CreateBackup:=False
  206.     Exit Sub
  207. ErrorHandler:
  208.     MsgBox ("Error while saving file." & Chr(13) & Chr(10) & "File was not saved!")
  209.     Resume Next
  210. End Sub
  211.  
  212. Sub ComponentList()
  213. '
  214. ' ComponentList Macro
  215. '
  216.  
  217. ' Initialization
  218.    GetPrefix
  219.     If strPrefix = Null Then
  220.        OneLineFamilyList = Array(("M"), ("AC"), ("DISC"), ("LS"), ("SOL"), ("CR"), ("PLC"), ("RECPT"), ("FAN"), ("XF"), ("PS"), ("PV"), ("CP"), ("ES"), ("VFD"), ("DRIVE"), ("SV"), ("PDB"), ("SR")) ' List of family codes to be included in one-line label file
  221.        TwoLineFamilyList = Array(("FU"), ("CB"))                ' List of family codes to be included in two-line label file
  222.        ThreeLineFamilyList = Array(("MTR"), ("HB"), ("CBM"))  ' List of family codes to be included in three-line label file
  223.        ValveFamilyList = Array("SOL")  ' List of family codes to be included in special valve label file
  224.    
  225.     Else
  226.         OneLineFamilyList = Array((strPrefix & "M"), (strPrefix & "AC"), (strPrefix & "DISC"), (strPrefix & "LS"), (strPrefix & "CR"), (strPrefix & "SOL"), (strPrefix & "PLC"), (strPrefix & "RECPT"), (strPrefix & "FAN"), (strPrefix & "CP"), (strPrefix & "XF"), (strPrefix & "PS"), _
  227.         (strPrefix & "PV"), (strPrefix & "ES"), (strPrefix & "VFD"), (strPrefix & "DRIVE"), (strPrefix & "SV"), (strPrefix & "PDB"), (strPrefix & "SR")) ' List of family codes to be included in one-line label file
  228.        TwoLineFamilyList = Array((strPrefix & "FU"), (strPrefix & "CB"))  ' List of family codes to be included in two-line label file
  229.        ThreeLineFamilyList = Array((strPrefix & "MTR"), (strPrefix & "HB"), (strPrefix & "CBM")) ' List of family codes to be included in three-line label file
  230.        ValveFamilyList = Array((strPrefix & "SOL"))  ' List of family codes to be included in special valve label file
  231.  
  232.      End If
  233.      
  234.      
  235.      ''EDITED BY ANDREW
  236.     Dim TwoLineFamilyListOmit As Variant
  237.      TwoLineFamilyListOmit = Array(("CBL"), ("TAG"), ("DESC"))
  238.    
  239.     Application.ScreenUpdating = True ' To avoid screen flicker.  Set to True before exiting macro. --previous value:false
  240.    
  241.    
  242.     TotalRows = ActiveSheet.UsedRange.Rows.Count
  243.     TolalCols = ActiveSheet.UsedRange.Columns.Count
  244.    
  245.     TotalSheets = Sheets.Count
  246.     If TotalSheets > 1 Then
  247.         For Sh = TotalSheets To 2 Step -1
  248.             Sheets(Sh).Delete
  249.         Next Sh
  250.     End If
  251.        
  252.     Sheets(1).Activate
  253.     Sheets(1).Name = "Raw List"
  254.     Sheets("Raw List").Select
  255.     Sheets("Raw List").Copy After:=Sheets(1)
  256.     Sheets(2).Select
  257.     Sheets(2).Name = "1-Lines"
  258.     Sheets("Raw List").Select
  259.     Sheets("Raw List").Copy After:=Sheets(2)
  260.     Sheets(3).Select
  261.     Sheets(3).Name = "2-Lines"
  262.     Sheets("Raw List").Select
  263.     Sheets("Raw List").Copy After:=Sheets(3)
  264.     Sheets(4).Select
  265.     Sheets(4).Name = "3-Lines Motors"
  266.     Sheets("Raw List").Select
  267.     Sheets("Raw List").Copy After:=Sheets(4)
  268.     Sheets(5).Select
  269.     Sheets(5).Name = "Valves"
  270.  
  271. ' Valve Procedure
  272.    Sheets(5).Select
  273.    
  274.     Tag = 0
  275.     Desc = Array(0, 0, 0, 0, 0) ' Allow up to five description fields
  276.    DescCount = 0
  277.     Inst = 0
  278.    
  279. ' Locate Description Column Headers
  280.    For Col = 1 To 8 ' Max of eight columns to find
  281.        Head$ = ActiveSheet.Cells(1, Col).Value
  282.         If (InStr(1, Head$, "DESC", 1)) > 0 Then
  283.             Desc(DescCount) = Col
  284.             DescCount = DescCount + 1
  285.         End If
  286.     Next Col
  287.  
  288. ' Eliminate crap columns that AutoCAD creates
  289.    Dim JunkRange As Range
  290.     Set JunkRange = ActiveSheet.Columns(DescCount + 3)
  291.     For Col = (DescCount + 3) To 214
  292.         Set JunkRange = Union(JunkRange, ActiveSheet.Columns(Col))
  293.     Next Col
  294.     JunkRange.Delete Shift:=xlToLeft
  295.  
  296.     If DescCount > 2 Then
  297. ' Combine description columns into one
  298. '        For Row = 2 To TotalRows
  299. '            For DescIndex = 1 To DescCount - 1
  300. '                If Cells(Row, Desc(DescIndex)).Value <> "" Then
  301. '                    Cells(Row, Desc(0)).Value = Cells(Row, Desc(0)).Value + " " + Cells(Row, Desc(DescIndex)).Value
  302. '                End If
  303. '            Next DescIndex
  304. '        Next Row
  305. ' Remove extra description columns
  306.        For DescIndex = DescCount - 1 To 2 Step -1
  307.             Columns(Desc(DescIndex)).Delete Shift:=xlToLeft
  308.         Next DescIndex
  309.     End If
  310.    
  311. ' Locate remaining column headers
  312.    For Col = 1 To 8 ' Max of eight columns to find
  313.        Head$ = ActiveSheet.Cells(1, Col).Value
  314.         If Head$ = "TAGNAME" Then
  315.             Tag = Col
  316.         ElseIf Head$ = "INST" Then
  317.             Inst = Col
  318.         End If
  319.     Next Col
  320.  
  321. ' Format remaining columns
  322.    ActiveSheet.Cells(1, Tag).Value = "TAG"
  323.     If DescCount > 0 Then
  324.         ActiveSheet.Cells(1, Desc(0)).Value = "DESC 1"
  325.     End If
  326.     If DescCount > 1 Then
  327.         ActiveSheet.Cells(1, Desc(1)).Value = "DESC 2"
  328.     End If
  329.     ActiveSheet.Rows(1).Font.Bold = True
  330.     For Col = 1 To (DescCount + 3)
  331.         ActiveSheet.Columns(Col).EntireColumn.AutoFit
  332.     Next Col
  333.  
  334.    
  335. ' Test TAG column for filter
  336.    For Row = TotalRows To 2 Step -1
  337.         CurrentTag$ = ActiveSheet.Cells(Row, Tag).Value
  338.         Keep = False
  339.         For i = 0 To UBound(ValveFamilyList)
  340.             If (InStr(1, CurrentTag$, ValveFamilyList(i), 1)) = 1 Then
  341.                 Keep = True
  342.             End If
  343.         Next i
  344.        
  345.         If Not Keep Then
  346.             Rows(Row).Delete
  347.         End If
  348.     Next Row
  349.    
  350. ' Delete Installation code column - not wanted on labels
  351.    ActiveSheet.Columns(Inst).Delete
  352.  
  353. ' Sort remaining entries based on first column
  354.    Columns("A:C").Select
  355.     Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, _
  356.         OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
  357.    
  358. ' Move cursor
  359.    Cells(1, 1).Select
  360.     ActiveWindow.ScrollColumn = 1
  361.  
  362. ' #############################################################################
  363.  
  364. ' 3-Line Procedure
  365.    Sheets(4).Select
  366.    
  367.     Tag = 0
  368.     Desc = Array(0, 0, 0, 0, 0) ' Allow up to five description fields
  369.    DescCount = 0
  370.     Inst = 0
  371.    
  372. ' Locate Description Column Headers
  373.    For Col = 1 To 8 ' Max of eight columns to find
  374.        Head$ = ActiveSheet.Cells(1, Col).Value
  375.         If (InStr(1, Head$, "DESC", 1)) > 0 Then
  376.             Desc(DescCount) = Col
  377.             DescCount = DescCount + 1
  378.         End If
  379.     Next Col
  380.  
  381. ' Eliminate crap columns that AutoCAD creates
  382.    Set JunkRange = ActiveSheet.Columns(DescCount + 3)
  383.     For Col = (DescCount + 3) To 214
  384.         Set JunkRange = Union(JunkRange, ActiveSheet.Columns(Col))
  385.     Next Col
  386.     JunkRange.Delete Shift:=xlToLeft
  387.  
  388.     If DescCount > 2 Then
  389. ' Combine description columns into one
  390. '        For Row = 2 To TotalRows
  391. '            For DescIndex = 1 To DescCount - 1
  392. '                If Cells(Row, Desc(DescIndex)).Value <> "" Then
  393. '                    Cells(Row, Desc(0)).Value = Cells(Row, Desc(0)).Value + " " + Cells(Row, Desc(DescIndex)).Value
  394. '                End If
  395. '            Next DescIndex
  396. '        Next Row
  397. ' Remove extra description columns
  398.        For DescIndex = DescCount - 1 To 2 Step -1
  399.             Columns(Desc(DescIndex)).Delete Shift:=xlToLeft
  400.         Next DescIndex
  401.     End If
  402.    
  403. ' Locate remaining column headers
  404.    For Col = 1 To 8 ' Max of eight columns to find
  405.        Head$ = ActiveSheet.Cells(1, Col).Value
  406.         If Head$ = "TAGNAME" Then
  407.             Tag = Col
  408.         ElseIf Head$ = "INST" Then
  409.             Inst = Col
  410.         End If
  411.     Next Col
  412.  
  413. ' Format remaining columns
  414.    ActiveSheet.Cells(1, Tag).Value = "TAG"
  415.     If DescCount > 0 Then
  416.         ActiveSheet.Cells(1, Desc(0)).Value = "DESC 1"
  417.     End If
  418.     If DescCount > 1 Then
  419.         ActiveSheet.Cells(1, Desc(1)).Value = "DESC 2"
  420.     End If
  421.     ActiveSheet.Rows(1).Font.Bold = True
  422.     For Col = 1 To (DescCount + 3)
  423.         ActiveSheet.Columns(Col).EntireColumn.AutoFit
  424.     Next Col
  425.  
  426.    
  427. ' Test TAG column for filter
  428.    For Row = TotalRows To 2 Step -1
  429.         CurrentTag$ = ActiveSheet.Cells(Row, Tag).Value
  430.         Keep = False
  431.         For i = 0 To UBound(ThreeLineFamilyList)
  432.             If (InStr(1, CurrentTag$, ThreeLineFamilyList(i), 1)) = 1 Then
  433.                 Keep = True
  434.             End If
  435.         Next i
  436.        
  437.         If Not Keep Then
  438.             Rows(Row).Delete
  439.         End If
  440.     Next Row
  441.    
  442. ' Delete Installation code column - not wanted on labels
  443.    ActiveSheet.Columns(Inst).Delete
  444.  
  445. ' Sort remaining entries based on first column
  446.    Columns("A:C").Select
  447.     Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, _
  448.         OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
  449.    
  450. ' Move cursor
  451.    Cells(1, 1).Select
  452.     ActiveWindow.ScrollColumn = 1
  453.  
  454. ' #############################################################################
  455.  
  456. ' 2-Line Procedure
  457.    Sheets(3).Select
  458.    
  459.     Tag = 0
  460.     Desc = Array(0, 0, 0, 0, 0) ' Allow up to five description fields
  461.    DescCount = 0
  462.     Inst = 0
  463.    
  464. ' Locate Description Column Headers
  465.    For Col = 1 To 8 ' Max of eight columns to find
  466.        Head$ = ActiveSheet.Cells(1, Col).Value
  467.         If (InStr(1, Head$, "DESC", 1)) > 0 Then
  468.             Desc(DescCount) = Col
  469.             DescCount = DescCount + 1
  470.         End If
  471.     Next Col
  472.  
  473. ' Eliminate crap columns that AutoCAD creates
  474.    Set JunkRange = ActiveSheet.Columns(DescCount + 3)
  475.     For Col = (DescCount + 3) To 214
  476.         Set JunkRange = Union(JunkRange, ActiveSheet.Columns(Col))
  477.     Next Col
  478.     JunkRange.Delete Shift:=xlToLeft
  479.  
  480.     If DescCount > 1 Then
  481. ' Combine description columns into one
  482. '        For Row = 2 To TotalRows
  483. '            For DescIndex = 1 To DescCount - 1
  484. '                If Cells(Row, Desc(DescIndex)).Value <> "" Then
  485. '                    Cells(Row, Desc(0)).Value = Cells(Row, Desc(0)).Value + " " + Cells(Row, Desc(DescIndex)).Value
  486. '                End If
  487. '            Next DescIndex
  488. '        Next Row
  489. ' Remove extra description columns
  490.        For DescIndex = DescCount - 1 To 1 Step -1
  491.             Columns(Desc(DescIndex)).Delete Shift:=xlToLeft
  492.         Next DescIndex
  493.     End If
  494.    
  495. ' Locate remaining column headers
  496.    For Col = 1 To 8 ' Max of eight columns to find
  497.        Head$ = ActiveSheet.Cells(1, Col).Value
  498.         If Head$ = "TAGNAME" Then
  499.             Tag = Col
  500.         ElseIf Head$ = "INST" Then
  501.             Inst = Col
  502.         End If
  503.     Next Col
  504.  
  505. ' Format remaining columns
  506.    ActiveSheet.Cells(1, Tag).Value = "TAG"
  507.     If DescCount > 0 Then
  508.         ActiveSheet.Cells(1, Desc(0)).Value = "DESCRIPTION"
  509.     End If
  510.     ActiveSheet.Rows(1).Font.Bold = True
  511.     For Col = 1 To (DescCount + 3)
  512.         ActiveSheet.Columns(Col).EntireColumn.AutoFit
  513.     Next Col
  514.  
  515.    
  516. ' Test TAG column for filter
  517.    For Row = TotalRows To 2 Step -1
  518.         CurrentTag$ = ActiveSheet.Cells(Row, Tag).Value
  519.         Keep = False
  520.         For i = 0 To UBound(TwoLineFamilyList)
  521.             If (InStr(1, CurrentTag$, TwoLineFamilyList(i), 1)) = 1 Then
  522.                 Keep = True
  523.             End If
  524.         Next i
  525.        
  526.     ''ANDREW
  527.    For i = 0 To UBound(TwoLineFamilyListOmit)
  528.         If (InStr(1, CurrentTag$, TwoLineFamilyListOmit(i), 1)) = 1 Then
  529.             Keep = False
  530.             Exit For
  531.         End If
  532.     Next i
  533.        
  534.         If Not Keep Then
  535.             Rows(Row).Delete
  536.         End If
  537.     Next Row
  538. '###############################################################################################################################################################
  539.  
  540.  ' TotalRows = ActiveSheet.UsedRange.Rows.Count
  541.  
  542. 'x = 4000
  543. 'y = 1
  544.    
  545. '    For x = TotalRows To 1 Step -1
  546.          
  547. '          Cells(x, y).Select  ' Add Line Below to add more text filter
  548. '      If ((InStr((Cells(x, y).Value), "CBL"))) = 1 Then
  549. '          Selection.EntireRow.Delete
  550. '          End If
  551.          
  552. '     Next x
  553.    
  554. '  Cells(1, y).Select
  555.  
  556. '###############################################################################################################################################################
  557.  
  558.    
  559. ' Delete Installation code column - not wanted on labels
  560.    ActiveSheet.Columns(Inst).Delete
  561.  
  562. ' Sort remaining entries based on first column
  563.    Columns("A:C").Select
  564.     Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, _
  565.         OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
  566.    
  567. ' Move cursor
  568.    Cells(1, 1).Select
  569.     ActiveWindow.ScrollColumn = 1
  570.  
  571. ' #############################################################################
  572.  
  573. ' 1-Line Procedure
  574.    Sheets(2).Select
  575.    
  576.     Tag = 0
  577.     Desc = Array(0, 0, 0, 0, 0) ' Allow up to five description fields
  578.    DescCount = 0
  579.     Inst = 0
  580.    
  581. ' Locate Description Column Headers
  582.    For Col = 1 To 8 ' Max of eight columns to find
  583.        Head$ = ActiveSheet.Cells(1, Col).Value
  584.         If (InStr(1, Head$, "DESC", 1)) > 0 Then
  585.             Desc(DescCount) = Col
  586.             DescCount = DescCount + 1
  587.         End If
  588.     Next Col
  589.  
  590. ' Eliminate crap columns that AutoCAD creates
  591.    Set JunkRange = ActiveSheet.Columns(DescCount + 3)
  592.     For Col = (DescCount + 3) To 214
  593.         Set JunkRange = Union(JunkRange, ActiveSheet.Columns(Col))
  594.     Next Col
  595.     JunkRange.Delete Shift:=xlToLeft
  596.    
  597.  
  598.     If DescCount > 0 Then
  599. ' Combine description columns into one
  600. '        For Row = 2 To TotalRows
  601. '            For DescIndex = 1 To DescCount - 1
  602. '                If Cells(Row, Desc(DescIndex)).Value <> "" Then
  603. '                    Cells(Row, Desc(0)).Value = Cells(Row, Desc(0)).Value + " " + Cells(Row, Desc(DescIndex)).Value
  604. '                End If
  605. '            Next DescIndex
  606. '        Next Row
  607. ' Remove extra description columns
  608.        For DescIndex = DescCount - 1 To 0 Step -1
  609.             Columns(Desc(DescIndex)).Delete Shift:=xlToLeft
  610.         Next DescIndex
  611.     End If
  612.    
  613. ' For 1-Line labels, remove description column
  614. '    Columns(Desc(0)).Delete Shift:=xlToLeft
  615.    
  616. ' Locate remaining column headers
  617.    For Col = 1 To 8 ' Max of eight columns to find
  618.        Head$ = ActiveSheet.Cells(1, Col).Value
  619.         If Head$ = "TAGNAME" Then
  620.             Tag = Col
  621.         ElseIf Head$ = "INST" Then
  622.             Inst = Col
  623.         End If
  624.     Next Col
  625.  
  626. ' Format remaining columns
  627.    ActiveSheet.Cells(1, Tag).Value = "TAG"
  628.     ActiveSheet.Cells(1, Desc(0)).Value = "DESCRIPTION"
  629.     ActiveSheet.Rows(1).Font.Bold = True
  630.     For Col = 1 To (DescCount + 3)
  631.         ActiveSheet.Columns(Col).EntireColumn.AutoFit
  632.     Next Col
  633.  
  634.    
  635. ' Test TAG column for filter
  636.    For Row = TotalRows To 2 Step -1
  637.         CurrentTag$ = ActiveSheet.Cells(Row, Tag).Value
  638.         Keep = False
  639.         For i = 0 To UBound(OneLineFamilyList)
  640.             If (InStr(1, CurrentTag$, OneLineFamilyList(i), 1)) = 1 Then
  641.                 Keep = True
  642.             End If
  643.         Next i
  644.        
  645.         For i = 0 To UBound(TwoLineFamilyList)
  646.             If (InStr(1, CurrentTag$, TwoLineFamilyList(i), 1)) = 1 Then
  647.                 Keep = False
  648.             End If
  649.         Next i
  650.        
  651.         For i = 0 To UBound(ThreeLineFamilyList)
  652.             If (InStr(1, CurrentTag$, ThreeLineFamilyList(i), 1)) = 1 Then
  653.                 Keep = False
  654.             End If
  655.         Next i
  656.        
  657.         For i = 0 To UBound(ValveFamilyList)
  658.             If (InStr(1, CurrentTag$, ValveFamilyList(i), 1)) = 1 Then
  659.                 Keep = False
  660.             End If
  661.         Next i
  662.        
  663.         If Not Keep Then
  664.             Rows(Row).Delete
  665.         End If
  666.     Next Row
  667.    
  668. ' Delete Installation code column - not wanted on labels
  669.    ActiveSheet.Columns(Inst).Delete
  670.  
  671.  
  672. ' Remove duplicate    ############################################################################################ Added By MJH ###############################################################
  673.    Cells(1, 1).Select
  674.     Columns("A:A").Select
  675.     ActiveSheet.Range("$A$1:$A$2000").RemoveDuplicates Columns:=1, Header:=xlYes
  676. '    #############################################################################################################################################################################
  677.    
  678. '###############################################################################################################################################################
  679.  
  680.   TotalRows = ActiveSheet.UsedRange.Rows.Count
  681.  
  682. x = 4000
  683. y = 1
  684.    
  685.     For x = TotalRows To 1 Step -1
  686.          
  687.           Cells(x, y).Select  ' Add Line Below to add more text filter
  688.      If ((InStr((Cells(x, y).Value), "CBL"))) = 1 Then
  689.           Selection.EntireRow.Delete
  690.           End If
  691.          
  692.      Next x
  693.    
  694.   Cells(1, y).Select
  695.  
  696. '###############################################################################################################################################################
  697.  
  698.  
  699. ' Sort remaining entries based on first column
  700.    Columns("A:C").Select
  701.     Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, _
  702.         OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
  703.        
  704. ' Move cursor
  705.    Cells(1, 1).Select
  706.     ActiveWindow.ScrollColumn = 1
  707.    
  708.     Application.ScreenUpdating = True
  709.     Sheets(1).Activate
  710.     ActiveWindow.ScrollColumn = 1
  711.     Cells(1, 1).Select
  712.    
  713. ' Save as CSV file, preserving the original XLS file
  714. ' Prompt user for project number
  715.    On Error GoTo ErrorHandler
  716.         Path$ = ActiveWorkbook.Path
  717.         'MsgBox (Path$)
  718.        
  719.         DefaultNum$ = Left(ActiveWorkbook.Name, 5)
  720.         If Not (DefaultNum$ Like "[0-9][0-9][0-9][0-9][0-9]") Then
  721.             DefaultNum$ = ""
  722.         End If
  723.         ProjectNum$ = InputBox("Please enter the 5-digit project number:", "Project Number", DefaultNum$)
  724.         'GetPrefix
  725.        Filename$ = Path$ + "\" + ProjectNum$ + "_Components.xls"
  726.         Filename1$ = Path$ + "\" + ProjectNum$ + "_Labels_1Line_Panel.txt"
  727.         Filename2$ = Path$ + "\" + ProjectNum$ + "_Labels_2Line_Fuses.txt"
  728.         Filename3$ = Path$ + "\" + ProjectNum$ + "_Labels_3Line_Motors.txt"
  729.         Filename4$ = Path$ + "\" + ProjectNum$ + "_Labels_Valves.txt"
  730.        
  731.         Sheets(1).Select
  732.         ActiveWorkbook.SaveAs Filename:=Filename$, _
  733.         FileFormat:=xlExcel7, Password:="", WriteResPassword:="", _
  734.         ReadOnlyRecommended:=False, CreateBackup:=False
  735.        
  736.         Sheets(2).Select
  737.         ActiveWorkbook.SaveAs Filename:=Filename1$, FileFormat:=xlCSV, CreateBackup:=False
  738.        
  739.         Sheets(3).Select
  740.         ActiveWorkbook.SaveAs Filename:=Filename2$, FileFormat:=xlCSV, CreateBackup:=False
  741.        
  742.         Sheets(4).Select
  743.         ActiveWorkbook.SaveAs Filename:=Filename3$, FileFormat:=xlCSV, CreateBackup:=False
  744.        
  745.         Sheets(5).Select
  746.         ActiveWorkbook.SaveAs Filename:=Filename4$, FileFormat:=xlCSV, CreateBackup:=False
  747.     Exit Sub
  748. ErrorHandler:
  749.     MsgBox ("Error while saving file." & Chr(13) & Chr(10) & "File was not saved!")
  750.     Resume Next
  751. End Sub
  752.  
  753.  
  754. Sub WireLabels()
  755. '
  756. ' WireLabels Macro
  757. '
  758.  
  759. '
  760. ' Initialization
  761.    Application.ScreenUpdating = False ' To avoid screen flicker.  Set to True before exiting macro.
  762.    GetPrefix
  763. ' Sort entries
  764.    Range("A1").Select
  765.     Selection.Cut
  766.     Range("H19").Select
  767.     ActiveSheet.Paste
  768.     Rows("1:1").Select
  769.     Selection.Delete Shift:=xlUp
  770.     Columns("A:A").Select
  771.     Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
  772.         OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
  773.     Rows("1:1").Select
  774.     Selection.Insert Shift:=xlDown
  775.     Range("H19").Select
  776.     Selection.Cut
  777.     Range("A1").Select
  778.     ActiveSheet.Paste
  779.    
  780.     Application.ScreenUpdating = True
  781.    
  782. ' Save as XLS file, preserving the original XLS file
  783. ' Prompt user for project number
  784.    On Error GoTo ErrorHandler
  785.         Path$ = ActiveWorkbook.Path
  786.         'MsgBox (Path$)
  787.        
  788.         DefaultNum$ = Left(ActiveWorkbook.Name, 5)
  789.         If Not (DefaultNum$ Like "[0-9][0-9][0-9][0-9][0-9]") Then
  790.             DefaultNum$ = ""
  791.         End If
  792.         ProjectNum$ = InputBox("Please enter the 5-digit project number:", "Project Number", DefaultNum$)
  793.         'GetPrefix
  794.        Filename$ = Path$ + "\" + ProjectNum$ + "_Wire_Labels.xls"
  795.         ActiveWorkbook.SaveAs Filename:=Filename$, FileFormat:=xlExcel7, CreateBackup:=False
  796.     Exit Sub
  797. ErrorHandler:
  798.     MsgBox ("Error while saving file." & Chr(13) & Chr(10) & "File was not saved!")
  799.     Resume Next
  800. End Sub
  801.  
  802.  
  803. Sub GetPrefix()
  804.  
  805. strPrefix = InputBox("Please Enter a special Prefix or leave blank for normal naming")
  806.  
  807. End Sub
  808.  
  809. Sub Macro_Terminal_Numbers_Export()
  810. '
  811. ' Macro_Wire_Label_Export Macro
  812. ' Exporting terminal markers to notepad
  813. '
  814. '------------------------
  815. ' Definitions
  816. '------------------------
  817.  
  818. Dim myfile As String
  819. Dim sheet_Number As Integer
  820. 'myfile = sheet_Number & ".txt"
  821. Dim filepath As String
  822. Dim celldata As String
  823. Dim CurrentRow, LastRow As Integer
  824. Dim Number_Of_Cells_to_Copy As Integer
  825. Dim Z As Boolean
  826. '------------------------
  827. ' start of code
  828. '------------------------
  829.  
  830. ' CHANGED BY ANDREW
  831. sheet_Number = 1
  832. Number_Of_Cells_to_Copy = 200 '''''
  833. LastRow = 2
  834.  
  835. Worksheets("Sheet1").Activate
  836.  
  837. Do
  838.    
  839.     'highlight the necessary area
  840.    CurrentRow = LastRow
  841.     LastRow = LastRow + Number_Of_Cells_to_Copy
  842.    
  843.     'open the file and past the contents
  844.    myfile = Application.DefaultFilePath & "\Terminal_Markers" & sheet_Number & ".txt"
  845.  
  846.     Open myfile For Output As #1
  847.        
  848.     'write the data
  849.    For x = CurrentRow To LastRow
  850.         Print #1, Range("A" & CurrentRow).Value
  851.         CurrentRow = CurrentRow + 1
  852.     Next x
  853.    
  854.     Close #1
  855.     sheet_Number = sheet_Number + 1
  856.    
  857.     LastRow = LastRow + 1
  858.     Application.CutCopyMode = False
  859.  
  860. Loop Until ActiveSheet.Range("A" & LastRow).Value = ""
  861.  
  862. MsgBox ("The files are located in My Documents. Move them to your project folder on J:")
  863.  
  864. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!