求一段vba代码

Question

工作簿的每个工作表用vba实现："部件编码"这列的内容替换为工作表名称括号里面的内容（例如C2:C11都等于"板1”，"数量"这列替换为1,然后把A/I/J/K/L/M/N/O列删除。 最后再把所有的工作表合并成一个表，每个表用一空白行隔开。
注意：

每个工作簿的sheet数量不固定的

Answer 1

'注意:使用前请备份原来工作簿!因为使用后 , 原有工作表内的数据将会修改!
'请自行测试该代码是否达到预期效果.
'由于对你的表不是太熟悉,所以有些地方采用了"硬编码",另外如果有隐藏的工作表,也可能会失败或者报错!请自行排查
'代码已经经过的测试 , 可以运行
Public Sub 测试()
Dim wb As Workbook
Dim strname As String
Dim sht As Worksheet
Dim arr
Dim 标题1 As String
Dim 标题2 As String
Worksheets(1).Select
标题1 = Cells(1, "c")
标题2 = Cells(1, "h")
Dim 最后单元格 As Range
arr = Range("a1:h1") '先把列标题保存下来
Application.ScreenUpdating = False
For Each sht In Worksheets
sht.Activate
If sht.Name <> Worksheets(1).Name Then '如果不是第一个工作表,那么删除第一行中的标题
Rows(1).Delete
End If
第一括号 = InStr(1, sht.Name, "(")
第二括号 = InStr(1, sht.Name, ")")
On Error Resume Next
strname = Mid(sht.Name, 第一括号 + 1, 第二括号 - 第一括号 - 1)
If Err.Number <> 0 Then
MsgBox "工作表不含括号", vbCritical, "错误"
Exit Sub
End If
On Error GoTo 0
Set 最后单元格 = Cells(Rows.Count, "c").End(3)
Intersect(最后单元格.CurrentRegion, Columns("c")) = strname
Intersect(最后单元格.CurrentRegion, Columns("h")) = 1
For t = 1 To 20
Columns("i").Delete '为了方便,我这里把"I"右边的全部给删除了
Next
Next

For Each sht In Worksheets
sht.Activate
If sht.Name <> Worksheets(1).Name Then
Cells().CurrentRegion.Copy Worksheets(1).Cells(Rows.Count, "a").End(3).Offset(2, 0)
End If

Next
Worksheets(1).Select
Cells(1, "c") = 标题1
Cells(1, "h") = 标题2
Application.ScreenUpdating = True
End Sub