搞定了请斑竹关闭

fallrains · 发表于 2024-5-6 11:56

本帖最后由 fallrains 于 2024-5-6 13:57 编辑

请斑竹关闭 RT

limonet · 发表于 2024-5-6 12:05

听不懂，哪位听懂了？

baofa2 · 发表于 2024-5-6 12:42

Option Explicit
Sub test0() '现成的，改了两处关键词 branch
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 = "branch"
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 = "branch"
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("A1").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

复制代码

WANT-T · 发表于 2024-5-6 12:51

感谢分享，祝您生活愉快，再见

fallrains · 发表于 2024-5-6 13:24

baofa2 发表于 2024-5-6 12:42

这个应该只有拆分吧，合并用哪个呢

baofa2 · 发表于 2024-5-6 14:11

本帖最后由 baofa2 于 2024-5-6 14:19 编辑

fallrains 发表于 2024-5-6 13:24
这个应该只有拆分吧，合并用哪个呢

Sub test2() '据提供作表汇总，首行标题预先自拟，工作表无则添加。能写这些，是不易的……请先谢人！
Dim path_ As String, files_() As String
path_ = ThisWorkbook.Path & "\分簿\"
If Not GetFileName(files_, path_, ".xlsx") Then MsgBox "!": Exit Sub
DoApp False
Dim Conn As Object, rs As Object, Cata As Object, tb As Object, dict As Object
Dim strConn As String, SQL As String, s As String, t As String
Dim i As Long, j As Long, iCount As Long, pos() As Long, vKey
Set rs = CreateObject("ADODB.Recordset")
Set Conn = CreateObject("ADODB.Connection")
Set Cata = CreateObject("ADOX.Catalog")
Set dict = CreateObject("Scripting.Dictionary")
ReDim pos(1 To Worksheets.Count)
For i = 1 To Worksheets.Count
pos(i) = 1
With Worksheets(i)
.UsedRange.Offset(pos(i)).ClearContents
Set dict(.Name & "$") = CreateObject("Scripting.Dictionary")
End With
Next
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;HDR=YES';Data Source="
Else
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES';Data Source="
End If
Conn.Open strConn & ThisWorkbook.FullName
For i = LBound(files_) To UBound(files_)
SQL = "SELECT * FROM [" & s & files_(i) & "].[[t$]] WHERE LEN(`branch`)"
Cata.ActiveConnection = strConn & files_(i)
For Each tb In Cata.Tables
If tb.Type = "TABLE" Then
t = Replace(tb.Name, "'", vbNullString)
If Right(t, 1) = "$" Then
If Not dict.Exists(t) Then
Set dict(t) = CreateObject("Scripting.Dictionary")
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Left(t, Len(t) - 1)
ReDim Preserve pos(1 To Worksheets.Count)
pos(UBound(pos)) = 1
End If
dict(t).Add Replace(SQL, "[t$]", t), vbNullString
End If
End If
Next
iCount = iCount + 1
If iCount = 49 Then
For Each vKey In dict.Keys
If dict(vKey).Count Then
Set rs = Conn.Execute(Join(dict(vKey).Keys, " UNION ALL "))
With Worksheets(Left(vKey, Len(vKey) - 1))
.Cells(pos(.Index) + 1, "A").CopyFromRecordset rs
pos(.Index) = .Cells.Find("*", , , , 1, 2).Row
End With
dict(vKey).RemoveAll
End If
Next
iCount = 0
End If
Next
If iCount > 0 Then
For Each vKey In dict.Keys
If dict(vKey).Count Then
Set rs = Conn.Execute(Join(dict(vKey).Keys, " UNION ALL "))
With Worksheets(Left(vKey, Len(vKey) - 1))
.Cells(pos(.Index) + 1, "A").CopyFromRecordset rs
End With
End If
Set dict(vKey) = Nothing
Next
End If
Set Cata = Nothing
rs.Close
Set rs = Nothing
Conn.Close
Set Conn = Nothing
Set dict = Nothing
DoApp
Beep
End Sub
Function GetFileName(files_, path_ As String, ext As String) As Boolean
Dim idx As Long, cnt As Long
Dim strDir As String, Folders_(9999) As String
If Right(path_, 1) <> "\" Then path_ = path_ & "\"
Do
strDir = Dir(path_, vbDirectory)
Do
If strDir <> "." And strDir <> ".." Then
If (GetAttr(path_ & strDir) And vbDirectory) = vbDirectory Then
cnt = cnt + 1
Folders_(cnt) = path_ & strDir & "\"
Debug.Print Folders_(cnt)
Else
If LCase(Right(strDir, Len(ext))) = LCase(ext) Then '限于指定的文件扩展名
idx = idx + 1
ReDim Preserve files_(1 To idx)
files_(idx) = path_ & strDir
End If
End If
End If
strDir = Dir
Loop While Len(strDir)
If cnt = 0 Then Exit Do
path_ = Folders_(cnt)
cnt = cnt - 1
Loop
GetFileName = CBool(idx)
End Function
Function DoApp(Optional b As Boolean = True)
With Application
.ScreenUpdating = b
.DisplayAlerts = b
.Calculation = -b * 30 - 4135
End With
End Function

复制代码

fallrains · 发表于 2024-5-9 10:47

baofa2 发表于 2024-5-6 14:11

谢谢大神无私帮助

		自动登录	找回密码
密码			免费注册

[求助] 搞定了请斑竹关闭

浏览过的版块

[求助] 搞定了 请斑竹关闭

浏览过的版块

[求助] 搞定了请斑竹关闭