工作薄数据归类的问题

杨小妹

附件 工作薄数据归类附件.rar (69.86 KB, 下载次数: 9)

2025-3-25 15:56 上传

点击文件名下载附件

谢谢老师！

ykcbf1100

附件供参考。。。

ykcbf1100

1. Sub ykcbf()  '//2025.3.25
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Dim tm: tm = Timer
   
6.     Set ws = ThisWorkbook
   
7.     p = ws.Path & ""
   
8.     xm = "Sheet0"
   
9.     For Each f In fso.GetFolder(p).Files
   
10.         If LCase$(f.Name) Like "*.xls*" Then
    
11.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
12.                 fn = "Sheet" & ston(fso.GetBaseName(f))
    
13.                 Set wb = Workbooks.Open(f, 0)
    
14.                 wb.Sheets(xm).Cells.Copy ws.Sheets(fn).[a1]
    
15.                 wb.Close 0
    
16.             End If
    
17.         End If
    
18.     Next f
    
19.     Application.ScreenUpdating = True
    
20.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
21. End Sub
    
22. 
    
23. Function ston(st)
    
24.     Dim reg As Object
    
25.     Set reg = CreateObject("VBScript.RegExp")
    
26.     With reg
    
27.         .Pattern = "[^\d]"
    
28.         .Global = True
    
29.         .IgnoreCase = True
    
30.     End With
    
31.     ston = reg.Replace(st, "") * 1
    
32.     Set reg = Nothing
    
33. End Function
    

复制代码

shiruiqiang

原来的表格数据是否存在，不存在就新增，
代码稍有不同

IE_Crayon

供参考

1. Option Explicit
   
2. 
   
3. Sub byz_demo()
   
4. 
   
5.     Dim wb As Workbook, lujing As String
   
6.     Dim F As String, r1 As Range
   
7.     Dim wb1 As Workbook, ws1 As Worksheet
   
8.     Dim i2, i3
   
9. 
   
10.     Set wb = ActiveWorkbook
    
11.     lujing = wb.Path
    
12.     F = Dir(lujing & "\A*.xlsb")
    
13.    
    
14.     i3 = 1
    
15.    
    
16.     Do While F <> ""
    
17.    
    
18.         Dim ws As Worksheet
    
19.         Dim sheetExists As Boolean
    
20.             sheetExists = False
    
21.         ' 检查是否存在名为 "Sheet1" 的工作表
    
22.         For Each ws In wb.Worksheets
    
23.             If ws.Name = "Sheet" & i3 Then
    
24.                 sheetExists = True
    
25.                 i3 = i3 + 1
    
26.                 Exit For
    
27.             End If
    
28.         Next ws
    
29.         ' 如果工作表不存在，则新增
    
30.         If Not sheetExists Then
    
31.             Set ws = wb.Worksheets.Add
    
32.             ws.Name = "Sheet" & i3
    
33.         End If
    
34.    
    
35.         Set wb1 = Workbooks.Open(lujing & "" & F)
    
36.         Set ws1 = wb1.Worksheets("Sheet0")
    
37.    
    
38.         i2 = ws1.Cells(Cells.Rows.Count, "A").End(xlUp).Row + 1
    
39.         Set r1 = ws1.Range("A1:CV" & i2 - 1): r1.Copy
    
40.             
    
41.         ws.Range("A1:CV" & 1 + r1.Rows.Count).PasteSpecial Paste:=xlPasteAll ' 粘贴所有内容和格式
    
42.         Application.CutCopyMode = False
    
43.          
    
44.         wb1.Close
    
45.         F = Dir
    
46.     Loop: wb.Save
    
47.    
    
48. End Sub

复制代码