现有一包含多张工作表的工作簿,其中表sheet8和sheet9行数相同(表头都占3行)且适用同一分类规则,则复制生成N个工作簿,每个工作簿的sheet8和sheet9仅包含一种分类内容,保留表头,其他表保持不变。本人VBA小白,求大神出手!
- Sub Macro1()
- Dim wb As Workbook, d, i&, h&, l%, j&
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Set d = CreateObject("scripting.dictionary")
- Set wb = GetObject(ThisWorkbook.Path & "\源.xls")
- arr = wb.Sheets("Sheet8").Range("a3").CurrentRegion
- h = UBound(arr): l = UBound(arr, 2)
- For i = 4 To h
- d(arr(i, 1)) = d(arr(i, 1)) & "," & i
- Next
- wb.Close 0
- a = d.keys: b = d.items
- For i = 0 To d.Count - 1 '另存为工作簿
- Set wb = GetObject(ThisWorkbook.Path & "\源.xls")
- Application.Windows(wb.Name).Visible = True
- wb.SaveAs Filename:=ThisWorkbook.Path & "" & a(i) & ".xls"
- With Workbooks(a(i))
- For j = h To 4 Step -1
- If InStr(b(i) & ",", "," & j & ",") = 0 Then
- .Sheets("sheet8").Rows(j).Delete
- .Sheets("sheet9").Rows(j).Delete
- End If
- Next
- .Close 1
- End With
- Next
- Application.DisplayAlerts = True
- Application.ScreenUpdating = True
- End Sub
复制代码
|