Question

所以我想做的是从AutoCAD获取线号报告，并从报告中提取线号并将其传输到线标签打印机软件中以供我们的商店打印。

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

很难在excel文件中对电线标签进行排序，这给我带来了麻烦。我可以将线号手动排序到它们自己的文件中，但是我最终试图使过程的这一部分自动化。

因此，我在6个经过排序和完成的excel文件旁边上传了原始数据的图像。

如您所见，报告通过电线标记将电线标记与AutoCAD分开，而只是通过电线颜色和电线规格。电线颜色无关紧要。除16和18号规格外，每种规格的电线都有其自己的标记管电线标签。它们都可以装入3.2mm的管子中，但为简单起见，我还是将它们分开放置。

因此，每组电线标签都需要进入各自的文件，以供打印机进行进一步处理。它们最终将被更改为.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

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

文本的第一部分（左）不会更改“（（电线标签）电线层：”。）

这是您唯一要做的电线标签，还是可能还有其他标签？

使用不同的颜色可以有相同尺寸的电线，但是它们将一起进入同一份新工作簿。我们使用25种不同的线规标记以及一小部分其他的线标标记例如“电缆”，“电缆中继线”，“现场电线”，“ _ Multi_WIRE”和“多导体”

我们使用的电线尺寸如下。

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

特定的电线标签是否可能根本没有行？

不是，如果电线层上没有任何电线，它将不会出现在报告中。

代码编辑/更新 这就是我们目前正在努力的工作。有用。这不是完美的，但是可以完成工作。

 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

Answer 1

好的，所以我的理解是您要创建6个新的工作簿-14，12，10，8，6，以及不属于这些类别的所有其他内容。幸运的是，您正在使用的工作表很容易设置为通过A列进行一次循环-您要做的就是找出要在哪个工作表上放置数据。

最后，每个不是原始（Sheet1）的工作表都有一个新的工作簿。 请注意，我没有测试保存新工作簿部分。

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

'Add a worksheet for each category
With ThisWorkbook
    .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "WireLabels - 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

For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    If InStr(Cells(i, 1).Value, "Wire Layer") > 0 Then

        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 - All Others")
        End If

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

                If 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

'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\MyName\Desktop\" & ws.Name, FileFormat:=FileFormatNum
        Set wb = Nothing
    End If
Next ws

End Sub

Excel宏，可从AutoCAD

1 个答案: