数据透视表综合练习演示

87519027

谢谢分享

Amos2023

谢谢！！

jdjhfuudhbdb

1. Dim MyPath, MyName, AWbName,dirName,curVbsDirDim, fso,xlApp
   
2. Set fso = CreateObject("Scripting.FileSystemObject")
   
3. curVbsDir=fso.GetFolder(".").Path
   
4. Function BrowseForFile()
   
5.     Dim shell : Set shell = CreateObject("Shell.Application")
   
6.     Dim file : Set file = shell.BrowseForFolder(0, "选择文件夹:", &H4000, curVbsDir)
   
7.     BrowseForFile = file.self.Path
   
8. End Function
   
9. dirName=BrowseForFile
   
10. Set xlApp = WScript.CreateObject("Excel.Application")
    
11. Dim Wb, WbN,G , Num ,BOX ,fl,curWb
    
12. xlApp.ScreenUpdating = False
    
13. Set curWb=xlApp.Workbooks.Add()
    
14. Num = 0
    
15. If Not fso.FolderExists(dirName & "") Then
    
16.     MsgBox "文件夹" & dirName & "不存在！"
    
17. Else
    
18.     On Error Goto 0
    
19.     For Each fl In  fso.GetFolder(dirName).Files
    
20.         If fso.GetExtensionName(fl.Path) = "xlsx"  Then
    
21.             Num = Num + 1
    
22.             Set Wb=xlApp.Workbooks.open(fl.Path)
    
23.             For G = 1 To Wb.Sheets.Count
    
24.                     curWb.ActiveSheet.Cells(curWb.ActiveSheet.Range("A65536").End(-4162).Row+1, 1) = fl.Name & " FOR " & Wb.Sheets(G).Name
    
25.                 Wb.Sheets(G).UsedRange.Copy curWb.ActiveSheet.Cells(curWb.ActiveSheet.Range("A65536").End(-4162).Row+2, 1)        
    
26.             Next
    
27.             WbN = WbN & Chr(13) & Wb.Name
    
28.             Wb.Close False   
    
29.         End If
    
30.     Next
    
31.     xlApp.ScreenUpdating = True
    
32.     curWb.SaveAs curVbsDir & "" & fso.getfolder(dirName).Name & ".xlsx", 51
    
33.     xlApp.visible=True
    
34.     xlApp.WindowState=-4137
    
35.     MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
    
36. End If
    
37. Set fso = Nothing
    
38. Set xlApp=Nothing
    
39. 
    
40. '这段 VBScript 代码的功能是将一个文件夹中所有的 .xlsx 文件中的所有工作表合并到一个新的 Excel 文件中。以下是每个部分的功能：
    
41. '1. `BrowseForFile()` 函数用于打开一个对话框，让用户选择要合并的文件夹。
    
42. '2. `dirName` 变量存储用户选择的文件夹路径。
    
43. '3. `xlApp` 变量创建一个新的 Excel 应用程序对象。
    
44. '4. `curWb` 变量创建一个新的工作簿对象，作为合并后的文件。
    
45. '5. `Num` 变量用于计算合并的工作表数。
    
46. '6'. `For Each` 循环遍历文件夹中的所有文件。
    
47. '7. `If` 语句用于确定文件是否为 .xlsx 文件。
    
48. '8. `Set Wb` 语句打开当前文件，并将其存储在变量 `Wb` 中。
    
49. '9. `For` 循环遍历当前工作簿中的所有工作表。
    
50. '10. `curWb.ActiveSheet.Cells()` 语句将当前工作表的名称添加到新工作簿的第一列的下一个空单元格。
    
51. '11. `Wb.Sheets(G).UsedRange.Copy curWb.ActiveSheet.Cells()` 语句将当前工作表的内容复制到新工作簿的第一列下一个空单元格的下一行。
    
52. '12. `WbN` 变量存储已合并的工作簿的名称。
    
53. '13. `Wb.Close False` 语句关闭当前工作簿，不保存更改。
    
54. '14. `xlApp.ScreenUpdating = True` 语句启用屏幕更新。
    
55. '15. `curWb.SaveAs` 语句将新工作簿另存为当前脚本所在文件夹下的一个新文件，并使用文件夹的名称作为文件名。
    
56. '16. `xlApp.visible=True` 语句显示 Excel 应用程序窗口。
    
57. '17. `xlApp.WindowState=-4137` 语句将 Excel 应用程序窗口最小化。
    
58. '18. 最后，`MsgBox` 语句显示合并的工作表数和已合并的工作簿的名称。
    
59. '请注意，此代码使用了 Excel COM 对象，因此需要在运行代码之前确保已安装 Excel 并启用了 Microsoft Excel 对象库。[code]
    
60. 
    
61. 
    
62. 
    
63. Sub 汇总文件()
    
64. strPath = "D:\315\2023年\4月"
    
65. Dim str As String
    
66. Dim i As Integer
    
67. Dim wb As Workbook
    
68. str = Dir(strPath & "*.xlsx")
    
69. Do While str <> ""
    
70.    Set wb = Workbooks.Open(strPath & str)
    
71.    wb.Sheets(1).Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    
72.    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Split(wb.Name, ".")(0)
    
73.    wb.Close
    
74.    str = Dir
    
75. Loop
    
76. Sheets(1).Activate
    
77. Range("a1").Select
    
78. End Sub
    
79. 
    
80. Sub 合并当前工作簿下的所有工作表()
    
81. Application.ScreenUpdating = False '屏幕不再闪烁
    
82. For j = 1 To Sheets.Count
    
83. If Sheets(j).Name <> ActiveSheet.Name Then
    
84. X = Range("A65536").End(xlUp).Row + 1
    
85. Sheets(j).UsedRange.Copy Cells(X, 1)
    
86. End If
    
87. Next
    
88. Range("B1").Select
    
89. Application.ScreenUpdating = True
    
90. MsgBox "当前工作簿下的全部工作表已经合并完毕！", vbInformation, "提示"
    
91. End Sub

复制代码

[/code]

jdjhfuudhbdb

jdjhfuudhbdb 发表于 2023-4-16 11:50
[/code]

当源数据有差异时，用sql会卡吗

1. Dim backupPath
   
2. backupPath="D:\315\2023年\4月"
   
3. ShowAllWorkbooks
   
4. Sub ShowAllWorkbooks()
   
5. Dim objFSO, objFolder, objFile, i, outFile
   
6. Set objFSO = CreateObject("Scripting.FileSystemObject")
   
7. Set outFile = objFSO.CreateTextFile("生成SQL.txt", True)
   
8. Set objFolder = objFSO.GetFolder(backupPath)
   
9. i = 0
   
10. For Each objFile In objFolder.Files
    
11.     If objFSO.GetExtensionName(objFile.Path) = "xlsx" Then
    
12.         SQL="SELECT [Sheet1$].单号, [Sheet1$].源仓位, [Sheet1$].源s量, [Sheet1$].图号, [Sheet1$].CJ日期" &vbCrLf& _
    
13.             "FROM [" & objFile.Path & "].[Sheet1$] [Sheet1$]"
    
14.             If i = 0 Then
    
15.                 strContents = SQL
    
16.             Else
    
17.                 strContents =  "union" &vbCrLf& SQL                          
    
18.             End If
    
19.         outFile.WriteLine strContents
    
20.     End If
    
21. i = i + 1
    
22. Next
    
23. outFile.Close
    
24. End Sub

复制代码