用于从AutoCAD对导线尺寸进行排序的Excel宏

所以我要做的是，我有一份来自AutoCAD的线号报告，我从报告中提取线号，并将其传输到线标签打印机软件中，供我们的商店打印

做报告很容易；使用打印机软件和打印标签很容易

在excel文件中对导线标签进行排序很困难，这给了我一些问题。我可以手动将线号排序到它们自己的文件中，但我最终尝试将这部分过程自动化

因此，我上传了一个原始数据的图像，旁边是6个已排序和完成的excel文件

如您所见，该报告通过导线将导线标记与AutoCAD分开，而AutoCAD仅通过导线颜色和导线规格进行区分。电线的颜色不重要。除16号和18号规格外，每种规格的导线都有自己的标记管导线标签；它们都可以放在3.2毫米的管子里，但为了简单起见，我还是把它们分开了

因此，每组导线标签都需要转到各自的文件，以便打印机进一步处理。它们最终将被更改为.csv文件，但这些文件很难处理，所以我最后做了这一部分，不管怎么说都很简单

WireLabels - 18AWG - 3.2mm .xlsm
WireLabels - 16AWG - 3.2mm .xlsm 
WireLabels - 14AWG - 3.6mm .xlsm 
WireLabels - 12AWG - 4.2mm .xlsm 
WireLabels - 10AWG - 5.0mm .xlsm 
WireLabels - 8AWG - 6.0mm .xlsm 
WireLabels - 6AWG - 8.0mm .xlsm 

我基本上是想弄清楚如何循环遍历该列，并将每组线号排序到它们自己的文件中

使用一组数字非常简单，但由于AutoCAD在不同项目中的报告不同，我无法设置从A5到A8的特定范围，这正是我遇到的难题。。。我一直试图选择一个范围到空白单元格，通过每一位数字，但不能超过这一点。

任何洞察都会令人惊讶。谢谢

---

能否显示您现有的代码或您迄今为止尝试过的代码？

Sub NewSheets()
'
' Macro1 Macro
'This is is just to have a place to send the groups of numbers for now.
'They will eventually go to their own new workbooks

'
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
     Sheets("Sheet1").Select
End Sub

Sub wires14()
  Range("A64:A69").Select
    Selection.Cut
    Sheets("Sheet3").Select
    ActiveSheet.Paste

     Dim wb As Workbook

    '// Set as reference to a new, one-sheet workbook.                              //
    Set wb = Workbooks.Add(xlWBATWorksheet)
    With wb
        '// Skip selecting the sheet, just reference it explicitly and copy it after//
        '// the blank sheet in the new wb.                                          //
        ThisWorkbook.Worksheets("sheet3").Copy After:=.Worksheets(.Worksheets.Count)
        '// Kill alerts, delete the blank sheet in the new wb and turn alerts back on//
        Application.DisplayAlerts = False
        .Worksheets(1).Delete
        Application.DisplayAlerts = True
        '// SaveAs the new workbook to whatever path and close.                     //
        .SaveAs Filename:="C:\Users\Public\Desktop\" & "14AWG - 4.6mm"
        .Close False
    End With

    ActiveCell.Offset(rowOffset:=3, columnOffset:=3).Activate
    Sheets("Sheet1").Select
End Sub

因此，我有一个按钮，可以排序的选择，并保存为文件，但自动通过，寻找和选择 没有特别地调用一系列的单元格，我就被卡住了

我尝试的这个位可以选择特定的线号，并将以下编号复制到新的图纸上，但同样，它只能获取指定的范围 无法应对不断变化的范围

Sub NewSheets()
'
' Macro1 Macro
'This is is just to have a place to send the groups of numbers for now.
'They will eventually go to their own new workbooks

'
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
     Sheets("Sheet1").Select
End Sub

Sub LoopThruA()

  Columns("A:A").Select
    Selection.Find(What:="_18", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    ActiveCell.Offset(1, 0).Select
Range(Selection, "A32").Select
     Selection.Copy
    Sheets("Sheet2").Select
    Range("A1").Select
    ActiveSheet.Paste

  End Sub

另外，BLU 18和BLK 16是否将成为唯一共享工作簿的电线？

6号、8号、10号、12号和14号都有自己的工作簿。 16号、18号和以上未提及的所有其他标签将位于同一工作簿中。 之所以如此，是因为“电缆”标签和更大规格的电线将使用3.2毫米的管子，通过拉链扎成一条线，并简单地缠绕在周围

所有这些线号的顺序是否始终相同（我知道行数将发生变化）。

根据“（导线标签）导线图层：BLK_12_MTW”部分标题，顺序始终为字母/数字 因此，一个示例顺序是

                (Wire Label)Wire Layer:BLK_12_MTW 
                (Wire Label)Wire Layer:BLK_16_MTW
                (Wire Label)Wire Layer:BLK_16_THHN_FW
                (Wire Label)Wire Layer:BLK_18_MTW
                (Wire Label)Wire Layer:BLK_2_MTW   (2 gauge wire)
                (Wire Label)Wire Layer:BLK_2-0_MTW (2 ought wire)
                (Wire Label)Wire Layer:BLK_4_MTW
                (Wire Label)Wire Layer:BLK_6_MTW
                (Wire Label)Wire Layer:BLU_18_MTW
                (Wire Label)Wire Layer:BLU_18_THHN_FW
                (Wire Label)Wire Layer:CABLE
                (Wire Label)Wire Layer:FIELDWIRE
                (Wire Label)Wire Layer:RED_18_MTW
                (Wire Label)Wire Layer:WHT_18_MTW

如果顺序不同，说明框中的文本是否会更改？

Sub NewSheets()
'
' Macro1 Macro
'This is is just to have a place to send the groups of numbers for now.
'They will eventually go to their own new workbooks

'
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
     Sheets("Sheet1").Select
End Sub

Sub wires14()
  Range("A64:A69").Select
    Selection.Cut
    Sheets("Sheet3").Select
    ActiveSheet.Paste

     Dim wb As Workbook

    '// Set as reference to a new, one-sheet workbook.                              //
    Set wb = Workbooks.Add(xlWBATWorksheet)
    With wb
        '// Skip selecting the sheet, just reference it explicitly and copy it after//
        '// the blank sheet in the new wb.                                          //
        ThisWorkbook.Worksheets("sheet3").Copy After:=.Worksheets(.Worksheets.Count)
        '// Kill alerts, delete the blank sheet in the new wb and turn alerts back on//
        Application.DisplayAlerts = False
        .Worksheets(1).Delete
        Application.DisplayAlerts = True
        '// SaveAs the new workbook to whatever path and close.                     //
        .SaveAs Filename:="C:\Users\Public\Desktop\" & "14AWG - 4.6mm"
        .Close False
    End With

    ActiveCell.Offset(rowOffset:=3, columnOffset:=3).Activate
    Sheets("Sheet1").Select
End Sub

文字的第一部分（左）不会更改“（导线标签）导线图层：”

这些是您唯一需要这样做的导线标签吗，或者还有其他导线标签吗？

Sub NewSheets()
'
' Macro1 Macro
'This is is just to have a place to send the groups of numbers for now.
'They will eventually go to their own new workbooks

'
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
     Sheets("Sheet1").Select
End Sub

Sub wires14()
  Range("A64:A69").Select
    Selection.Cut
    Sheets("Sheet3").Select
    ActiveSheet.Paste

     Dim wb As Workbook

    '// Set as reference to a new, one-sheet workbook.                              //
    Set wb = Workbooks.Add(xlWBATWorksheet)
    With wb
        '// Skip selecting the sheet, just reference it explicitly and copy it after//
        '// the blank sheet in the new wb.                                          //
        ThisWorkbook.Worksheets("sheet3").Copy After:=.Worksheets(.Worksheets.Count)
        '// Kill alerts, delete the blank sheet in the new wb and turn alerts back on//
        Application.DisplayAlerts = False
        .Worksheets(1).Delete
        Application.DisplayAlerts = True
        '// SaveAs the new workbook to whatever path and close.                     //
        .SaveAs Filename:="C:\Users\Public\Desktop\" & "14AWG - 4.6mm"
        .Close False
    End With

    ActiveCell.Offset(rowOffset:=3, columnOffset:=3).Activate
    Sheets("Sheet1").Select
End Sub

使用不同的颜色，可以有相同大小的导线，但它们将一起进入同一个新工作簿。 我们使用了25种不同的线规名称和一小部分其他电线标签标记 例如“电缆”、“电缆干线”、“现场接线”、“多芯线”和“多导体”

我们使用的导线尺寸如下

18
16
14
12
10
8
6
4   (4 gauge)
4-0 (4 ought)
3   (3 gauge)
3-0 (3 ought, etc...)
2
2-0
1
1-0
250
300
350
400
500
600
700
750
800
900
1000

每个数字都有一个尾随名称，如_MTW或_THHN_FW

如果重要的话，可能的颜色是

BLK
BLU
BRN
GRN
ORG
RED
WHT-BLU
WHT
YEL

特定导线标签可能没有行吗？

Sub NewSheets()
'
' Macro1 Macro
'This is is just to have a place to send the groups of numbers for now.
'They will eventually go to their own new workbooks

'
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
    Sheets.Add After:=ActiveSheet
     Sheets("Sheet1").Select
End Sub

Sub wires14()
  Range("A64:A69").Select
    Selection.Cut
    Sheets("Sheet3").Select
    ActiveSheet.Paste

     Dim wb As Workbook

    '// Set as reference to a new, one-sheet workbook.                              //
    Set wb = Workbooks.Add(xlWBATWorksheet)
    With wb
        '// Skip selecting the sheet, just reference it explicitly and copy it after//
        '// the blank sheet in the new wb.                                          //
        ThisWorkbook.Worksheets("sheet3").Copy After:=.Worksheets(.Worksheets.Count)
        '// Kill alerts, delete the blank sheet in the new wb and turn alerts back on//
        Application.DisplayAlerts = False
        .Worksheets(1).Delete
        Application.DisplayAlerts = True
        '// SaveAs the new workbook to whatever path and close.                     //
        .SaveAs Filename:="C:\Users\Public\Desktop\" & "14AWG - 4.6mm"
        .Close False
    End With

    ActiveCell.Offset(rowOffset:=3, columnOffset:=3).Activate
    Sheets("Sheet1").Select
End Sub

不，如果导线层上没有任何导线，它就不会出现在报告中

代码编辑/更新 这就是我们现在的工作。它起作用了。这并不完美，但它确实起到了作用

 Option Explicit

Sub DivideWireLabels()




Dim i As Long, j As Long, K As Long
Dim sht As Worksheet, ws As Worksheet
Dim wb As Workbook


Workbooks("OpenAndRunWireLabel SortTool.xls").Activate

'Add a worksheet for each category
With ActiveWorkbook
    .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "WireLabels - 16-18 & All Others"
    .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "WireLabels - 14 AWG - 3_6mm"
    .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "WireLabels - 12 AWG - 4_2mm"
    .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "WireLabels - 10 AWG - 5_0mm"
    .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "WireLabels - 8 AWG - 6_0mm"
    .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "WireLabels - 6 AWG - 8_0mm"
End With

Sheets("Sheet1").Activate

'Loop thru the column




For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row

'Find the wire layer cell

    If InStr(Cells(i, 1).Value, "Wire Layer") > 0 Then

'if the wire layer is there, make a new sheet for it

        If InStr(Cells(i, 1).Value, "_14_") > 0 Then
            Set sht = Worksheets("WireLabels - 14 AWG - 3_6mm")
        ElseIf InStr(Cells(i, 1).Value, "_12_") > 0 Then
            Set sht = Worksheets("WireLabels - 12 AWG - 4_2mm")
        ElseIf InStr(Cells(i, 1).Value, "_10_") > 0 Then
            Set sht = Worksheets("WireLabels - 10 AWG - 5_0mm")
        ElseIf InStr(Cells(i, 1).Value, "_8_") > 0 Then
            Set sht = Worksheets("WireLabels - 8 AWG - 6_0mm")
        ElseIf InStr(Cells(i, 1).Value, "_6_") > 0 Then
            Set sht = Worksheets("WireLabels - 6 AWG - 8_0mm")
        Else
            Set sht = Worksheets("WireLabels - 16-18 & All Others")
        End If

'Take the data and put it in one of the new sheets

        For j = i + 1 To Cells(Rows.Count, 1).End(xlUp).Row
            If Trim(Cells(j, 1).Value) <> "" Then
                K = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row

                If Trim(sht.Cells(K, 1).Value) = "" Then
                    Cells(j, 1).Copy
                    sht.Cells(K, 1).PasteSpecial
                Else
                    Cells(j, 1).Copy
                    sht.Cells(K + 1, 1).PasteSpecial
                End If
            Else
                i = j
                Exit For
            End If
Next j

End If

Next i

'Clear clipboard
Application.CutCopyMode = False


'delete sheets 2 and 3
Dim s As Worksheet, t As String
    Dim L As Long, M As Long
    M = Sheets.Count

    For L = M To 1 Step -1
        t = Sheets(L).Name
        If t = "Sheet2" Or t = "Sheet3" Then
            Application.DisplayAlerts = False
                Sheets(L).Delete
            Application.DisplayAlerts = True
        End If
    Next L






'Create a workbook for each new worksheet
For Each ws In ActiveWorkbook.Worksheets
    If ws.Name <> "Sheet1" Then
        Set wb = ws.Application.Workbooks.Add
        ws.Copy Before:=wb.Sheets(1)
        wb.SaveAs "C:\Users\Public\Desktop\" & ws.Name, FileFormat:=xlCSV
        Set wb = Nothing
    End If
Next ws

ActiveWorkbook.Close SaveChanges:=True
ActiveWorkbook.Close SaveChanges:=True
ActiveWorkbook.Close SaveChanges:=True
ActiveWorkbook.Close SaveChanges:=True
ActiveWorkbook.Close SaveChanges:=True
ActiveWorkbook.Close SaveChanges:=True
ActiveWorkbook.Close SaveChanges:=True


   Dim x As Variant
    Dim Path As String

    ' Set the Path variable equal to the path of your program's installation
    Path = "C:\Program Files\Nisca Corporation\M-1ProVPC\MKP5PC.exe"

    x = Shell(Path, vbNormalFocus)

End Sub

选项显式
子分区线标签（）
我长，j长，K长
将sht设置为工作表，ws设置为工作表
将wb设置为工作簿
工作簿（“OpenAndRunWireLabel SortTool.xls”）。激活
'为每个类别添加工作表
使用ActiveWorkbook
.Sheets.Add（后面：=.Sheets（.Sheets.Count））.Name=“WireLabels-16-18和所有其他”
.Sheets.Add（后面：=.Sheets（.Sheets.Count））.Name=“WireLabels-14 AWG-3_6mm”
.Sheets.Add（后面：=.Sheets（.Sheets.Count））.Name=“WireLabels-12 AWG-4_2mm”
.Sheets.Add（后面：=.Sheets（.Sheets.Count））.Name=“WireLabels-10 AWG-5_0mm”
.Sheets.Add（后面：=.Sheets（.Sheets.Count））.Name=“WireLabels-8 AWG-6_0mm”
.Sheets.Add（后面：=.Sheets（.Sheets.Count））.Name=“WireLabels-6 AWG-8_0mm”
以
工作表（“工作表1”）。激活
'循环通过列
对于i=2到单元格（Rows.Count，1）。结束（xlUp）。行
'查找导线层单元
如果InStr（单元格（i，1）.值，“导线层”）>0，则
'如果存在导线层，请为其制作新的板材
如果InStr（单元格（i，1）.Value，“\u 14”>0，则
设置sht=工作表（“电线标签-14 AWG-3_6mm”）
ElseIf InStr（单元格（i，1）.值，“\u 12””>0，则
设置sht=工作表（“线标签-12 AWG-4_2mm”）
ElseIf InStr（单元格（i，1）.值，“\u 10””>0，则
设置sht=工作表（“线标签-10 AWG-5_0mm”）
ElseIf InStr（单元格（i，1）.值，“\u 8””>0，则
设置sht=工作表（“线标签-8 AWG-6_0mm”）
ElseIf InStr（单元格（i，1）.值，“\u 6””>0，则
设置sht=工作表（“线标签-6 AWG-8_0mm”）
其他的
设置sht=工作表（“线标签-16-18和所有其他”）
如果结束
“把数据放在一张新的表格里
对于j=i+1到单元格（Rows.Count，1）。结束（xlUp）。行
如果修剪（单元格（j，1）.Value）“，则
K=短单元格（短行数，1）.End（xlUp）.Row
如果修剪（短节）