Excel 用于从 AutoCAD 排序线尺寸的宏
Excel Macro for Sorting Wire sizes from AutoCAD
所以我想做的是我有一份来自 AutoCAD 的线号报告，我正在从报告中获取线号并将它们传输到电线标签打印机软件中，供我们的商店打印。
制作报告很容易；使用打印机软件和打印标签很容易。
在 excel 文件中对电线标签进行排序的困难给我带来了问题。我可以手动将线号分类到它们自己的文件中，但我最终会尝试使这部分过程自动化。
所以我在 6 个排序和完成的 excel 文件旁边上传了原始数据的图像。
如您所见，报告通过电线将电线标记与 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 的范围，这就是我卡住的地方...我一直在尝试 select 一个范围向下到空白单元格超过每一位数字但不能超过那个点。
任何见解都将是惊人的。谢谢！
能否请您展示您现有的代码或到目前为止您尝试过的代码？
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
所以我有一个按钮可以对 selection 进行排序并将其保存为文件，但会自动浏览、查找和 selecting
没有特别指出一组单元格是我卡住的地方。
我试过的这个位可以select特定的线号并将以下数字复制到一个新的sheet但是，同样，它只会抓取指定的范围
并且无法处理不断变化的范围。
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 gauge、8 gauge、10 gauge、12 gauge 和 14 gauge 都有自己的工作簿。
16 gauge、18 gauge 和上面未提及的所有其他标签都将在同一工作簿中。
之所以如此，是因为 'cable' 标签和更大规格的电线将使用 3.2 毫米管子，通过扎带串起来并简单地缠绕起来。
所有这些线号是否总是以相同的顺序排列（我知道行数会改变）。
顺序将始终是 alphabetical/numerical，基于“（电线标签）电线 Layer:BLK_12_MTW”部分 header
因此，示例顺序为
(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 种不同的线规名称和一小部分其他线标标记
例如 "Cable" "Cable Trunk" "FieldWires" "_Multi_WIRE" 和 "Multiconductor"
我们使用的电线尺寸如下。
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
特定电线标签是否可能根本没有行？
不，如果导线层上没有任何导线，它就不会出现在报告中。
代码EDIT/UPDATE
这就是我们现在的工作。有用。它并不完美，但可以胜任。
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
好的，我的理解是您正在创建 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
所以我想做的是我有一份来自 AutoCAD 的线号报告，我正在从报告中获取线号并将它们传输到电线标签打印机软件中，供我们的商店打印。
制作报告很容易；使用打印机软件和打印标签很容易。
在 excel 文件中对电线标签进行排序的困难给我带来了问题。我可以手动将线号分类到它们自己的文件中，但我最终会尝试使这部分过程自动化。
所以我在 6 个排序和完成的 excel 文件旁边上传了原始数据的图像。
如您所见，报告通过电线将电线标记与 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 的范围，这就是我卡住的地方...我一直在尝试 select 一个范围向下到空白单元格超过每一位数字但不能超过那个点。
任何见解都将是惊人的。谢谢！
能否请您展示您现有的代码或到目前为止您尝试过的代码？
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
所以我有一个按钮可以对 selection 进行排序并将其保存为文件，但会自动浏览、查找和 selecting 没有特别指出一组单元格是我卡住的地方。
我试过的这个位可以select特定的线号并将以下数字复制到一个新的sheet但是，同样，它只会抓取指定的范围 并且无法处理不断变化的范围。
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 gauge、8 gauge、10 gauge、12 gauge 和 14 gauge 都有自己的工作簿。 16 gauge、18 gauge 和上面未提及的所有其他标签都将在同一工作簿中。 之所以如此，是因为 'cable' 标签和更大规格的电线将使用 3.2 毫米管子，通过扎带串起来并简单地缠绕起来。
所有这些线号是否总是以相同的顺序排列（我知道行数会改变）。
顺序将始终是 alphabetical/numerical，基于“（电线标签）电线 Layer:BLK_12_MTW”部分 header 因此，示例顺序为
(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 种不同的线规名称和一小部分其他线标标记 例如 "Cable" "Cable Trunk" "FieldWires" "_Multi_WIRE" 和 "Multiconductor"
我们使用的电线尺寸如下。
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
特定电线标签是否可能根本没有行？
不，如果导线层上没有任何导线，它就不会出现在报告中。
代码EDIT/UPDATE 这就是我们现在的工作。有用。它并不完美，但可以胜任。
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
好的，我的理解是您正在创建 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