|
- Option Explicit
- Sub test0() '拆分
- Dim data, wks() As String, Flag() As Boolean
- Dim Ran As Range, Target As Range, Dict As Object, vrtKey
- Dim strPath As String, splitKey As String, strKey As String
- Dim i As Long, j As Long
- DoApp False
- strPath = ThisWorkbook.Path & "\分簿\"
- If Dir(strPath, vbDirectory) = "" Then MkDir strPath
- 'strPath = strPath & "\"
- Set Dict = CreateObject("Scripting.Dictionary")
- j = Worksheets.Count
- ReDim wks(1 To j), Flag(1 To j)
- splitKey = "管理单位"
- For j = 1 To UBound(wks)
- With Worksheets(j)
- Set Target = .UsedRange.Find(splitKey, , xlValues, , xlByRows, xlPrevious)
- If Not Target Is Nothing Then
- Flag(j) = True
- data = .Cells(1, Target.Column).Resize(.Cells(.Rows.Count, Target.Column).End(xlUp).Row)
- For i = Target.Row + Target.MergeArea.Rows.Count To UBound(data)
- strKey = Trim(data(i, 1))
- If Len(strKey) Then If Not Dict.Exists(strKey) Then Dict.Add strKey, vbNullString
- Next
- End If
- wks(j) = .Name
- End With
- Next
- For Each vrtKey In Dict.Keys
- Worksheets(wks).Copy
- With ActiveWorkbook
- For j = 1 To UBound(wks)
- If Flag(j) Then
- With .Worksheets(wks(j))
- .DrawingObjects.Delete
- Set Ran = .Rows(.Rows.Count)
- Set Target = .UsedRange.Find(splitKey, , xlValues, , xlByRows, xlPrevious)
- data = .Cells(1, Target.Column).Resize(.Cells(.Rows.Count, Target.Column).End(xlUp).Row)
- For i = Target.Row + Target.MergeArea.Rows.Count To UBound(data)
- If Trim(data(i, 1)) <> vrtKey Then Set Ran = Union(Ran, .Rows(i))
- Next
- Ran.Delete
- End With
- End If
- Next
- .SaveAs strPath & vrtKey & IIf(InStr(vrtKey, "."), ".xlsx", vbNullString), 51
- .Close
- End With
- Next
- Set Dict = Nothing
- Set Target = Nothing
- Set Ran = Nothing
- DoApp
- Beep
- End Sub
- Sub test1() '拆分 另一法
- Dim data, wks() As String, SQL(), pos() As Long, Flag() As Boolean
- Dim Conn As Object, Dict As Object, Target As Range, vrtKey
- Dim strPath As String, splitKey As String, strKey As String
- Dim i As Long, j As Long
- DoApp False
- strPath = ThisWorkbook.Path & "\分簿\"
- If Dir(strPath, vbDirectory) = "" Then MkDir strPath
- 'strPath = strPath & "\"
- Set Dict = CreateObject("Scripting.Dictionary")
- j = Worksheets.Count
- ReDim wks(1 To j), SQL(1 To j), pos(1 To j), Flag(1 To j)
- splitKey = "管理单位"
- For j = 1 To UBound(wks)
- With Worksheets(j)
- Set Target = .UsedRange.Find(splitKey, , xlValues, , xlByRows, xlPrevious)
- 'wks(j) = .Name
- If Not Target Is Nothing Then
- Flag(j) = True
- data = .Cells(1, Target.Column).Resize(.Cells(.Rows.Count, Target.Column).End(xlUp).Row)
- pos(j) = Target.Row + Target.MergeArea.Rows.Count
- For i = pos(j) To UBound(data)
- strKey = Trim(data(i, 1))
- If Len(strKey) Then If Not Dict.Exists(strKey) Then Dict.Add strKey, vbNullString
- Next
- wks(j) = .Name
- With .Range("A2").CurrentRegion
- SQL(j) = "SELECT * FROM [" & wks(j) & "$" & Intersect(.Offset(0), .Offset(pos(j) - 1)).Address(0, 0) & "] WHERE TRIM(F" & Target.Column & ")="
- End With
- End If
- End With
- Next
- Set Target = Nothing
- Set Conn = CreateObject("ADODB.Connection")
- Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=NO';Data Source=" & ThisWorkbook.FullName
- For Each vrtKey In Dict.Keys
- Worksheets(wks).Copy
- With ActiveWorkbook
- For j = 1 To UBound(wks)
- If Flag(j) Then
- With .Worksheets(wks(j))
- .DrawingObjects.Delete
- .UsedRange.Offset(pos(j) - 1).ClearContents
- .Cells(pos(j), "A").CopyFromRecordset Conn.Execute(SQL(j) & "'" & vrtKey & "'")
- End With
- End If
- Next
- .SaveAs strPath & vrtKey, 51
- .Close
- End With
- Next
- Conn.Close
- Set Conn = Nothing
- Set Dict = Nothing
- DoApp True
- Beep
- End Sub
- Function DoApp(Optional b As Boolean = True)
- With Application
- .ScreenUpdating = b
- .DisplayAlerts = b
- .Calculation = -b * 30 - 4135
- End With
- End Function
复制代码 |
评分
-
3
查看全部评分
-
|