全自动智能分表和合表

李筱龙 · 发表于 2024-5-21 15:48

我每个月需要做一项工作，就是让各乡镇上报名单给我进行核对、比对，无误后我再发给各单位，因名单为保密信息，所以各单位发给我的时候或我发给各单位的时候都是该一个单位的，但我进行比对时必须将所有单位合并到一个表里，所以每次都有大量的合表分表，我查阅过论坛之前的表，但都只有一个表的分表和合表，我一个工作薄里有N多个工作表，而且有几十个乡镇，每个乡镇每个名单表都几百人，用论坛的合表分表工具时工作量依然很大，所以请大神帮忙做一个VBA，可以满足我自动多个工作表分表和合表。注意事项：1、分表时，每个单位的序号重新编号；合表时，序号为累计编号；2、当某个乡镇某个名单里没有人员时，在姓名处显示一个“无”。

shiruiqiang · 发表于 2024-5-21 15:53

1、多表拆分简单；
2、当某个乡镇某个名单里没有人员时，在姓名处显示一个“无”。怎么显示？
目前的的应该是拆分吧？

ykcbf1100 · 发表于 2024-5-21 16:14

这个写起来比较耗时。

baofa2 · 发表于 2024-5-21 16:19

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

复制代码

3190496160 · 发表于 2024-5-21 16:26

Sub 汇总()
Application.ScreenUpdating = False
Dim ar As Variant
lj = ThisWorkbook.Path & "\"
f = Dir(lj & "*.xls*")
Set ww = ThisWorkbook
For Each sh In Sheets
sh.UsedRange.Offset(4).Borders.LineStyle = 0
sh.UsedRange.Offset(4) = Empty
Next sh
Do While f <> ""
If f <> ThisWorkbook.Name Then
      Set wb = Workbooks.Open(lj & f, 0)
      For Each sht In wb.Worksheets
         r = sht.Cells(Rows.Count, 1).End(xlUp).Row
         If r >= 5 Then
            rs = ww.Worksheets(sht.Name).Cells(Rows.Count, 1).End(xlUp).Row + 1
            If rs < 5 Then rs = 5
            sht.Rows("5:" & r).Copy ww.Worksheets(sht.Name).Cells(rs, 1)
         End If
      Next sht
      wb.Close False
End If
f = Dir
Loop
For Each sh In Sheets
r = sh.Cells(Rows.Count, 2).End(xlUp).Row
For i = 5 To r
      sh.Cells(i, 1) = i - 4
Next i
Next sh
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160 · 发表于 2024-5-21 16:28

测试.rar (60.78 KB, 下载次数: 40)

skiss · 发表于 2024-5-21 16:28

baofa2 发表于 2024-5-21 16:19

老师的代码写得好规范，学习。

ykcbf1100 · 发表于 2024-5-21 16:38

先写一个文件合并的代码吧，拆分的代码有时间再写。

ykcbf1100 · 发表于 2024-5-21 16:39

参与一下。。。

Sub ykcbf() '//2024.5.21
Set fso = CreateObject("scripting.filesystemobject")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set ws = ThisWorkbook
For Each sht In ws.Sheets
sht.Cells.Clear
Next
p = ws.Path & ""
For Each f In fso.GetFolder(p).Files
If f.Name Like "*.xls*" Then
If InStr(f.Name, ThisWorkbook.Name) = 0 Then
Set wb = Workbooks.Open(f, 0)
n = n + 1
For Each sht In wb.Sheets
If sht.[c5] <> "无" Then
With sht
fn = .Name
If n = 1 Then
sht.Cells.Copy ws.Sheets(fn).[a1]
Else
r = ws.Sheets(fn).Cells(ws.Sheets(fn).Rows.Count, 1).End(3).Offset(1).Row
sht.UsedRange.Offset(4).Copy ws.Sheets(fn).Cells(r, 1)
End If
End With
End If
Next
wb.Close False
End If
End If
Next f
For Each sht In ws.Sheets
m = 0
With sht
arr = .UsedRange
For i = 5 To UBound(arr)
m = m + 1
.Cells(i, 1) = m
Next
End With
Next
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

baofa2 · 发表于 2024-5-21 16:47

Option Explicit
Sub test2() '合并预先列出工作表名，并设定好标题。不超过49个工作簿
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 & "\"
Dim Conn As Object, Cata As Object, rs As Object, tb As Object, Dict As Object, wks As Worksheet
Dim strConn As String, f As String, s As String, t As String, j As Integer, k
Application.ScreenUpdating = False
s = "Excel 12.0;HDR=NO;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=NO';Data Source="
Else
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=NO';Data Source="
End If
Set Dict = CreateObject("Scripting.Dictionary")
Set Cata = CreateObject("ADOX.Catalog")
f = Dir(p & "*.xls*")
Do
If f <> ThisWorkbook.Name Then
Cata.ActiveConnection = strConn & p & f
For Each tb In Cata.Tables
If tb.Type = "TABLE" Then
t = Replace(tb.Name, "'", "")
If Right(t, 1) = "$" Then
Dict(t) = Dict(t) & " UNION ALL SELECT * FROM [" & s & p & f & "].[" & t & "A5:Z] WHERE F2 IS NOT NULL"
End If
End If
Next
End If
f = Dir
Loop While Len(f)
Set tb = Nothing
Set Cata = Nothing
Set Conn = CreateObject("ADODB.Connection")
Conn.Open strConn & ThisWorkbook.FullName
On Error Resume Next
t = ActiveSheet.Name
For Each k In Dict.Keys
s = Replace(k, "$", "")
Set wks = Worksheets(s)
If Err.Number Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = s
Err.Clear
End If
Set rs = Conn.Execute(Mid(Dict(k), 12))
With Worksheets(s)
.Range("A5:Z" & .Rows.Count).ClearContents
.Range("A5").CopyFromRecordset rs
End With
Next
Worksheets(t).Activate
Set rs = Nothing
Set wks = Nothing
Set Dict = Nothing
Conn.Close
Set Conn = Nothing
Application.ScreenUpdating = True
Beep
End Sub

复制代码

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

[求助] 全自动智能分表和合表

评分

评分

评分

评分