|
- Sub test1()
- Dim ar, data, rowHeights() As Double, dict As Object
- Dim i As Long, j As Long, x As Long, vKey As Variant
- Dim dstFolder As String, wb As String, ws As String
- Dim titleRow As Long, wbCol As Long, wsCol As Long
- DoApp False
- titleRow = 1
- wbCol = 1
- wsCol = 2
- ReDim rowHeights(1 To titleRow + 1)
- dstFolder = ThisWorkbook.Path & "\分簿分表"
- If Dir(dstFolder, vbDirectory) = "" Then MkDir dstFolder
- Set dict = CreateObject("Scripting.Dictionary")
- With ActiveSheet
- data = .Range("A1").CurrentRegion.Value
- j = UBound(data, 2)
- For i = titleRow + 1 To UBound(data)
- wb = data(i, wbCol)
- ws = Format(data(i, wsCol), "yyyy-m-d")
- If Not dict.Exists(wb) Then Set dict(wb) = CreateObject("Scripting.DictionAry")
- If Not dict(wb).Exists(ws) Then Set dict(wb)(ws) = .Range("A1").Resize(titleRow, j)
- Set dict(wb)(ws) = Union(dict(wb)(ws), .Range("A" & i).Resize(, j))
- Next
- For j = 1 To UBound(data, 2)
- data(1, j) = .Columns(j).ColumnWidth
- Next
- For i = 1 To UBound(rowHeights)
- rowHeights(i) = .Rows(i).RowHeight
- Next
- End With
- For Each vKey In dict.Keys
- Application.SheetsInNewWorkbook = dict(vKey).Count
- With Workbooks.Add
- For j = 0 To dict(vKey).Count - 1
- With .Worksheets(j + 1)
- dict(vKey).Items()(j).Copy .Range("A1")
- .Name = dict(vKey).Keys()(j)
- For i = 1 To UBound(data, 2)
- .Columns(i).ColumnWidth = data(1, i)
- Next
- For i = 1 To UBound(rowHeights) - 1
- .Rows(i).RowHeight = rowHeights(i)
- Next
- .Rows(i & ":" & .UsedRange.Rows.Count).RowHeight = rowHeights(i)
- .DrawingObjects.Delete
- ar = .UsedRange
- For i = 1 To UBound(ar)
- For x = 2 To UBound(ar, 2)
- ar(i, 1) = ar(i, 1) & "," & ar(i, x)
- Next
- Next
- ar = WorksheetFunction.Transpose(WorksheetFunction.Index(ar, 0, 1))
- Open dstFolder & "\" & vKey & "_" & .Name & ".txt" For Output As #8
- Print #8, Join(ar, vbCrLf)
- Close #8
- End With
- Next
- .SaveAs dstFolder & "\" & vKey, 51
- .Close
- End With
- Next
- With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
- .SetText ""
- .PutInClipboard
- End With
- Set dict = Nothing
- Application.SheetsInNewWorkbook = 1
- DoApp
- Beep
- End Sub
- Function DoApp(Optional b As Boolean = True)
- With Application
- .ScreenUpdating = b
- .DisplayAlerts = b
- .Calculation = -b * 30 - 4135
- End With
- End Function
复制代码 |
评分
-
1
查看全部评分
-
|