Question

我想：

从50
对每张纸上的第一张纸进行排序和过滤（该纸张的名称将是未知的）
过滤需要找到第J列中具有特定值的每一行 - 此值为＆＃39;否＆＃39;
所有符合条件的行（第J行包含＆＃39; no＆＃39;）需要放在主电子表格上
每次csv应在每次处理时关闭

我花了几个小时＆amp;在论坛上花了几个小时，并有一些我一直在修补的代码，但不能让它一起运行：

 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

电子表格数据具有可变长度我是否选择了最大值：

Range("A1:AC3100")

我认为还有比这更好的方法。

感谢任何帮助。

Answer 1

你的标准有点过于模糊，不能给出完美的回答，但我会对此采取行动。您的代码的某些部分看起来无关紧要或复杂，所以我根据您的最终目标执行此操作（所有行中，每个工作簿中包含'no'的第一个工作表中的J列中的值都将复制到主电子表格中。）< / p>

如果您的所有工作表始终位于同一文件夹中，则可以使myPath保持静态，而不是尝试使用msoFileDialogFolderPicker。当我尝试在我的计算机上运行代码时，它给了我一个 “内存不足” 错误，如果您有这个问题，我建议为myPath使用静态字符串。

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

我建议您在确认代码运行正常之前禁止事件。在考虑优化之前担心获取工作代码。

x = 1
Set masterWB = Workbooks("NAMEOFWORKBOOK")
Set pasteRange = masterWB.Sheets(1).Range("A" & x)
myPath = "C:\EXAMPLE\MOREEXAMPLE\*.csv"
myFile = Dir(myPath)

myPath可以设置为直接搜索字符串中的.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优先尝试获取过滤器，然后抓取过滤器显示的所有内容。

        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()

关闭您的第一个文件并设置下一个文件

Set pasteRange = masterWB.Sheets(1).Range("A" & x)

在内部循环外部设置主wb中的粘贴范围，否则它将覆盖从下一个文件再次从A1开始的值。

Loop

Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

我希望这对你有所帮助。我还建议您阅读VBA最佳实践，了解您未来使用的任何代码，例如使用Option Explicit并尽可能避免使用GoTo或.Select。

打开多个CSV文件，对每个文件进行排序和过滤，放置在主电子表格宏/ VBA中

1 个答案: