|
|
Sub test1() '按编号拆分成簿
Dim vData, vTemp(), vResult(), Dict As Object, vSht(1) As String
Dim i As Long, j As Long, posRow As Long, strPath As String
Dim titleRow As Long, splitCol As Long
titleRow = 1 '标题所在 行
splitCol = 2 '拆分依据 列
DoApp False
strPath = ThisWorkbook.Path & Application.PathSeparator & "按编号拆分成簿"
If Dir(strPath, vbDirectory) = "" Then MkDir strPath
strPath = strPath & Application.PathSeparator
Worksheets("销售明细").Activate
vSht(1) = ActiveSheet.Name
vSht(0) = Worksheets(1).Name
Set Dict = CreateObject("Scripting.Dictionary")
vData = Range("A1").CurrentRegion
ReDim vTemp(1 To UBound(vData), 1 To UBound(vData, 2))
For j = 1 To UBound(vData, 2)
For i = 1 To titleRow
vTemp(i, j) = vData(i, j)
Next
Next
For i = titleRow + 1 To UBound(vData)
If Not Dict.Exists(vData(i, splitCol)) Then Dict(vData(i, splitCol)) = Dict.Count + 1
Next
ReDim vResult(1 To Dict.Count, 1 To 2)
For i = 1 To Dict.Count
vResult(i, 1) = titleRow
vResult(i, 2) = vTemp
Next
For i = titleRow + 1 To UBound(vData)
posRow = Dict(vData(i, splitCol))
vResult(posRow, 1) = vResult(posRow, 1) + 1
For j = 1 To UBound(vData, 2)
vResult(posRow, 2)(vResult(posRow, 1), j) = vData(i, j)
Next
Next
For i = 1 To Dict.Count
Worksheets(vSht).Copy
With ActiveWorkbook
With .Worksheets(vSht(0))
.Range("C5") = vResult(i, 2)(titleRow + 1, splitCol)
.Name = Split(.Name, "-")(0) & "-" & vResult(i, 2)(titleRow + 1, splitCol)
End With
With .Worksheets(vSht(1))
'.Name = vResult(i, 2)(titleRow + 1, splitCol)
.Range("A1").Resize(vResult(i, 1), UBound(vData, 2)) = vResult(i, 2)
.DrawingObjects.Delete
.UsedRange.Offset(, UBound(vData, 2)).Clear
.UsedRange.Offset(vResult(i, 1)).Clear
End With
.SaveAs strPath & .Worksheets(1).Name, 51
.Close
End With
Next
Set Dict = Nothing
DoApp
End Sub
Sub test2() '选择文件夹汇总
Dim p As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path
If .Show Then p = .SelectedItems(1) Else Exit Sub
End With
If Right(p, 1) <> "\" Then p = p & "\"
Worksheets("销售明细").Activate
Cells.ClearContents
DoApp False
Dim Conn As Object, rs As Object, Target As Range, Dict As Object
Dim strConn As String, SQL As String, f As String, s As String
Dim Flag As Boolean, i As Integer
Set Target = Range("A2")
Set Dict = CreateObject("Scripting.Dictionary")
Set Conn = CreateObject("ADODB.Connection")
s = "Excel 12.0;HDR=yes;Database="
If Application.Version < 12 Then
s = Replace(s, "12.0", "8.0")
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
Else
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
End If
Conn.Open strConn & ThisWorkbook.FullName
'p = ThisWorkbook.Path & "\按编号拆分成簿\"
f = Dir(p & "*.xls?")
SQL = "SELECT * FROM [" & s & p & "[f]].[销售明细$A1:H] WHERE "
While Len(f)
If p & f <> ThisWorkbook.FullName Then
If Not Flag Then
Set rs = Conn.Execute(Replace(SQL, "[f]", f) & "FALSE")
For i = 0 To rs.Fields.Count - 1
If Not rs.Fields(i).Name Like "F[1-9]*" Then Range("A1").Offset(0, i) = rs.Fields(i).Name
Next
Set rs = Nothing
Flag = True
End If
Dict.Add Replace(SQL, "[f]", f) & "LEN(拆分编号)", vbNullString
If Dict.Count Mod 49 = 0 Then
Target.CopyFromRecordset Conn.Execute(Join(Dict.Keys, " UNION ALL "))
Set Target = Cells(Rows.Count, 1).End(xlUp).Offset(1)
Dict.RemoveAll
End If
End If
f = Dir
Wend
If Dict.Count Then Target.CopyFromRecordset Conn.Execute(Join(Dict.Keys, " UNION ALL "))
Conn.Close
Set Conn = Nothing
Set Target = Nothing
Set Dict = Nothing
DoApp
End Sub
Function DoApp(Optional b As Boolean = True)
With Application
.ScreenUpdating = b
.DisplayAlerts = b
.Calculation = -b * 30 - 4135
End With
If b Then Beep
End Function |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2022-11-23 15:48
楼主
