打开多个CSV文件，对每个数据进行sorting和过滤，放在主电子表格Macro / VBA中
我在尝试着：
- 从50个文件夹中打开电子表格
- 对每一张纸上的第一张纸进行分类和过滤（名字将在这张纸上是未知的）
- 过滤需要find列J中具有一定值的每一行 – 这个值是“否”
- 所有满足条件的行（J行包含“否”）需要被放置到主电子表格上
- 每个csv在每次处理时都应该closures
我花了几个小时在论坛上，并有一些代码，我一直在修补，但不能让它一起运行：
Sub LoopAllExcelFilesInFolder() 'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them 'SOURCE: www.TheSpreadsheetGuru.com Dim wb As Workbook Dim myPath As String Dim myFile As String Dim myExtension As String Dim FldrPicker As FileDialog 'Optimize Macro Speed Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual 'Retrieve Target Folder Path From User Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker) With FldrPicker .Title = "Select A Target Folder" .AllowMultiSelect = False If .Show <> -1 Then GoTo NextCode myPath = .SelectedItems(1) & "\" End With 'In Case of Cancel NextCode: myPath = myPath If myPath = "" Then GoTo ResetSettings 'Target File Extension (must include wildcard "*") myExtension = "*.csv*" 'Target Path with Ending Extention myFile = Dir(myPath & myExtension) 'Loop through each Excel file in folder Do While myFile <> "" 'Set variable equal to opened workbook Set wb = Workbooks.Open(Filename:=myPath & myFile) 'Ensure Workbook has opened before moving on to next line of code DoEvents Range("A1:AC3100").Select Selection.AutoFilter ActiveWindow.LargeScroll ToRight:=1 Range("Y2").Select ActiveSheet.Range("$A$1:$AC$3110").AutoFilter Field:=25, Criteria1:="No" Range("A1:AC3100").Select Range("Y2").Activate Selection.Copy Sheets.Add After:=Sheets(Sheets.Count) ActiveSheet.Paste Application.CutCopyMode = False Selection.Copy Windows("Book1").Activate Rows("1:1").Select Selection.Insert Shift:=xlDown 'Save and Close Workbook wb.Close SaveChanges:=True 'Ensure Workbook has closed before moving on to next line of code DoEvents 'Get next file name myFile = Dir Loop 'Message Box when tasks are completed MsgBox "Task Complete!" ResetSettings: 'Reset Macro Optimization Settings Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub 电子表格数据具有可变的长度，我做了最大的select：
Range("A1:AC3100")
我会认为还有比这更好的方法。
任何帮助将不胜感激。
你的标准有点太模糊，不能给出完美的答案，但我会采取一些措施。 代码的某些部分看起来是无关紧要的，所以我根据最终目标（每个工作簿中第一个包含“否”的工作表的J列中的值被复制到主电子表格中的所有行）执行此操作。
如果您的所有工作表都始终在同一个文件夹中，则可以使myPath静态，而不是尝试使用msoFileDialogFolderPicker。 当我试图在我的机器上运行你的代码时，它给了我一个“内存不足”的错误，如果你有这个问题，我build议myPath的静态string。
Option Explicit Sub PutInMasterFile() Dim wb As Workbook Dim masterWB As Workbook Dim rowNum As Integer Dim copyRange As Range Dim pasteRange As Range Dim myPath As String Dim myFile As String Dim FirstAddress As String Dim x As Variant Dim c As Variant Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual
我build议不要禁用事件，直到您确认您的代码正确运行。 在考虑优化之前，担心得到工作代码。
x = 1 Set masterWB = Workbooks("NAMEOFWORKBOOK") Set pasteRange = masterWB.Sheets(1).Range("A" & x) myPath = "C:\EXAMPLE\MOREEXAMPLE\*.csv" myFile = Dir(myPath)
可以将myPath设置为直接searchstring中的.csv文件。
Do While myFile <> vbNullString Workbooks.Open (myFile) With Workbooks(myFile).Sheets(1) Set c = .Range("J:J").Find("No", LookIn:=xlValues, lookat:=xlWhole)
在vba中使用.find优先尝试获取filter，然后抓取filter显示的所有内容。
If Not c Is Nothing Then FirstAddress = c.Address Do rowNum = c.Row Set copyRange = .Range(rowNum & ":" & rowNum) copyRange.Copy pasteRange.PasteSpecial x = x + 1 Set pasteRange = masterWB.Sheets(1).Range("A" & x)
将行复制到您的主表中。 x = x + 1保证您将新数据粘贴到新行以避免覆盖任何内容。
Set c = .Range("J:J").FindNext(c) Loop While Not c Is Nothing And FirstAddress <> c.Address End If End With Workbooks(myFile).Close myFile = Dir()
closures你的第一个文件，并获得下一个设置
Set pasteRange = masterWB.Sheets(1).Range("A" & x)
在内部循环之外的主wb中设置粘贴范围，否则它会用下一个文件再次覆盖从A1开始的值。
Loop Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub
我希望这对你有帮助。 我还build议您阅读VBA的最佳实践，了解您将来使用的任何代码，例如使用Option Explicit，并尽可能避免使用GoTo或.Select。