最热烈的问候，我是Excel VBA的新手。下面的代码给出了我想要的内容，但是执行需要很长时间。当我单独运行代码时，效果很好！但是当我组合所有宏时，只需要10个分钟就可以使用8个文件夹。 我不确定是否存在任何语法错误或导致代码运行缓慢的任何其他原因。我真的需要帮助你们！谢谢！
Sub FolderNames()
Dim xPath As String
Dim xWs As Worksheet
Dim FSO As Object, j As Long, folder1 As Object
Dim ABC As Long
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose the folder"
.Show
End With
On Error Resume Next
xPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
Set xWs = Application.ActiveSheet
xWs.Cells(1, 1).Resize(1, 3).Value = Array("FOLDER PATH", "FOLDER NAME", "OPTION")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set folder1 = FSO.getFolder(xPath)
getSubFolder folder1
xWs.Cells(1, 1).Resize(1, 3).Interior.Color = RGB(171, 222, 247)
xWs.Cells(1, 1).Resize(1, 3).Font.Bold = True
xWs.Cells(1, 1).Resize(1, 3).Font.Size = 14
xWs.Cells(1, 1).Resize(1, 3).HorizontalAlignment = xlCenter
Application.ScreenUpdating = True
End Sub
Sub getSubFolder(ByRef prntfld As Object)
Dim SubFolder As Object
Dim subfld As Object
Dim xRow As Long
Dim FileSystem As Object
counter = 1
For Each SubFolder In prntfld.SubFolders
If Left(UCase(SubFolder.Name), 5) = Range("E2") Then
counter = counter + 1
Range("A" & counter).Value = SubFolder.Path
Range("B" & counter).Value = SubFolder.Name
Range("C" & counter).Value = "Yes"
With Range("C" & counter).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="Yes,No"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Range("C" & counter).HorizontalAlignment = xlCenter
Columns.AutoFit
End If
Next SubFolder
End Sub
Sub SearchReport()
Dim FileSystem As Object
Application.ScreenUpdating = False
Workbooks("List Folder Name.xlsm").Worksheets("Main Menu").Activate
counter = 2
Do While Range("A" & counter).Value <> "" 'do when Range A is not empty (folder path)
If Range("C" & counter).Value = "Yes" Then 'check Range C, do when Range C = Yes
HostFolder = Range("A" & counter).Value & "\"
Set FileSystem = CreateObject("Scripting.FileSystemObject")
Report FileSystem.getFolder(HostFolder) 'HostFolder is the folder path from Range A
counter = counter + 1
Else
counter = counter + 1
End If
Loop
Application.ScreenUpdating = True
End Sub
Sub Report(Folder)
Dim SubFolder
Dim subfld As Folder
Dim subfldr As Folder
Dim File As File
Dim MyPath As String
Dim Wksht As Worksheet
Dim wbk As Workbook
Dim N As Long
Application.ScreenUpdating = False
For Each SubFolder In Folder.SubFolders 'loop through subfolders in the first folder path
If SubFolder.Name = "Report" Then 'look for a folder named "Report"
MyPath = SubFolder.Path & "\"
fileName = Dir(MyPath & "*al.dat") 'look for files which is ended with "al.dat" in the "Report" folder
Do While Len(fileName) > 0 'open the files
'Set Wksht = Worksheets.Add
'Wksht.Name = Left(fileName, Len(fileName) - 10)
Set wbk = Workbooks.Open(MyPath & fileName)
Set Wrksht = wbk.Worksheets(1)
find
'Wrksht.Cells.Copy Wksht.Cells
'Wrksht.Range(myRange).Cells.Copy Wksht.Cells
wbk.Close True
fileName = Dir
'find
Loop
Else
Sheets("Main Menu").Activate
Report SubFolder
End If
Next
End Sub
Sub find()
Dim FileSystem As Object
Dim Wksht As Worksheet
Dim wbk As Workbook
Dim text As String
Dim ws As Worksheet
Dim wsname As String
Dim CurrVal As String
Dim i As Long
Dim firstrow As Long
Dim lastrow As Long
Application.ScreenUpdating = False
For i = 1 To Rows.Count
text = Range("A" & i).Value
Select Case text
Case Is = "H.Freq (MHz)"
sort (i)
'code here
Case Is = "V.Freq (MHz)"
sort (i)
'code here
Case Is = "Tested Freq range:"
compare
End Select
Next i
End Sub
Sub CompareValues()
Dim lr As Long
Dim i As Long, X As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, "A").End(xlUp).Row
For i = lr To 2 Step -1
X = i - 1
If Cells(i, 1).Value = Cells(X, 1).Value Then
If Cells(i, 2).Value < Cells(X, 2).Value Then
Rows(i).Delete
' i = i - 1
ElseIf Cells(X, 2).Value < Cells(i, 2).Value Then
Rows(X).Delete
' i = i - 1
End If
End If
Next i
End Sub
Sub compare()
Dim FileSystem As Object
Dim Wksht As Worksheet
Dim wbk As Workbook
Dim text As String
Dim ws As Worksheet
Dim wsname As String
Dim X As String
Dim CurrVal As String
Dim i As Long
Dim firstrow As Long
Dim lastrow As Long
Dim H As String
Dim result As String
Application.ScreenUpdating = False
wsname = ActiveSheet.Name
For i = 1 To Rows.Count
text = Range("A" & i).Value
Select Case text
Case Is = "H.Freq (MHz)"
N = i + 1
Do While Range("A" & N).Value <> ""
result = Range("E" & N) - Range("D" & N)
If H = "" Then
H = result
HY = Range("A" & N)
HY2 = Range("D" & N & ":E" & N)
HX = wsname
Else
If result < H Then
H = result
HY = Range("A" & N)
HY2 = Range("D" & N & ":E" & N)
HX = wsname
End If
End If
M = Workbooks("List Folder Name.xlsm").Sheets("Result").Range("D3")
If M = "" Then
With Workbooks("List Folder Name.xlsm").Sheets("Result")
.Range("D3").Value = H
.Range("A1").Value = HX
.Range("A3") = HY
.Range("B3:C3") = HY2
End With
Else
If H < M Then
With Workbooks("List Folder Name.xlsm").Sheets("Result")
.Range("D3").Value = H
.Range("A1").Value = HX
.Range("A3") = HY
.Range("B3:C3") = HY2
End With
End If
End If
N = N + 1
Loop
'code here
Case Is = "V.Freq (MHz)"
N = i + 1
Do While Range("A" & N).Value <> ""
result = Range("E" & N) - Range("D" & N)
If V = "" Then
V = result
VY = Range("A" & N)
VY2 = Range("D" & N & ":E" & N)
VX = wsname
Else
If result < H Then
V = result
VY = Range("A" & N)
VY2 = Range("D" & N & ":E" & N)
VX = wsname
End If
End If
M = Workbooks("List Folder Name.xlsm").Sheets("Result").Range("D7")
If M = "" Then
With Workbooks("List Folder Name.xlsm").Sheets("Result")
.Range("D7").Value = V
.Range("A5").Value = VX
.Range("A7") = VY
.Range("B7:C7") = VY2
End With
Else
If V < M Then
With Workbooks("List Folder Name.xlsm").Sheets("Result")
.Range("D7").Value = V
.Range("A5").Value = VX
.Range("A7") = VY
.Range("B7:C7") = VY2
End With
End If
End If
N = N + 1
Loop
'code here
Case Is = "Tested Freq range:"
Exit Sub
End Select
Next i
End Sub
我知道代码很长但我真的需要帮助。