Question

我在一个文件夹中大约有1000个文件，我希望分别循环浏览它们，处理数据，然后在单独的* .xlsx工作簿中进行复制/粘贴。代码似乎在“处理”数据时出现问题，因为当我尝试返回Do-While-Loop时，它不会打开下一个文件。如果我不运行其他代码，它将遍历所有文件

Sub LoopThroughSingle_TXT_Files()
    Dim currentPath As String
    Dim currentFile As String

    Workbooks.Add
    ActiveWorkbook.SaveAs Filename:="D:\Folder2\cd1.xlsx"
    Dim cd1 As Workbook
    Set cd1 = Workbooks("cd1")

    currentPath = "D:\Folder1\Data\"
    currentFile = Dir(currentPath & "*.txt")
    Do While currentFile <> ""
        Workbooks.Add
        ActiveWorkbook.SaveAs Filename:="D:\Folder1\Data\wb1.xlsx"

        With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & currentPath & currentFile, Destination:=Range("$A$1"))
            .NAME = "Data"
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .TextFilePromptOnRefresh = False
            .TextFilePlatform = 437
            .TextFileStartRow = 1
            .TextFileParseType = xlDelimited
            .TextFileTextQualifier = xlTextQualifierDoubleQuote
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = False
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = True
            .TextFileSpaceDelimiter = False
            .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1)
            .TextFileTrailingMinusNumbers = True
            .Refresh BackgroundQuery:=False
        End With

        Module3.z_CleanData
        Module3.zz_paste_in_combined()

        currentFile = Dir

    Loop
    Application.ScreenUpdating = True

End Sub

Sub z_Clean_Data()

    Range("M2").Activate:     ActiveCell.FormulaR1C1 = "=IFS(AND(RC1="""",RC[-11]=""""),R[-1]C[-11],AND(RC1=1,RC[-11]=""""),R[1]C[-11],RC[-11]<>"""",RC[-11])"
    Range("N2").Activate:     ActiveCell.FormulaR1C1 = "=IFS(AND(RC1="""",RC[-11]=""""),R[-1]C[-11],AND(RC1=1,RC[-11]=""""),R[1]C[-11],RC[-11]<>"""",RC[-11])"
    Range("O2").Activate:     ActiveCell.FormulaR1C1 = "=IFS(AND(RC1="""",RC[-11]=""""),R[-1]C[-11],AND(RC1=1,RC[-11]=""""),R[1]C[-11],RC[-11]<>"""",RC[-11])"
    Range("P2").Activate:     ActiveCell.FormulaR1C1 = "=IFS(AND(RC1="""",RC[-11]=""""),R[-1]C[-11],AND(RC1=1,RC[-11]=""""),R[1]C[-11],RC[-11]<>"""",RC[-11])"
    Range("Q2").Activate:    ActiveCell.FormulaR1C1 = "=IF(RC[-11]="""",R[-1]C[-11],RC[-11])"
    lastRow = Cells(Rows.Count, "B").End(xlUp).Row
    Range("M2:Q" & lastRow).Activate:   Selection.FillDown:     Selection.Copy
    Range("B2").Activate:   Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False:    Application.CutCopyMode = False
    Range("M:Q").Delete

    Application.Goto Reference:="R1C1:R500C6":      Selection.Copy

End Sub

Sub zz_paste_in_combined()

    Dim wb1 As Window
    For Each wb1 In Application.Windows
        If wb1.Caption Like "wb1*.xlsx" Then
            wb1.Activate
            Exit For
        End If
    Next

    Dim cd1 As Window
    For Each cd1 In Application.Windows
        If cd1.Caption Like "cd1*.xlsx" Then
            cd1.Activate
            Exit For
        End If
    Next

    cd1.Activate
    Range("A1").End(xlDown).Offset(1, 0).Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False:
    Application.CutCopyMode = False

    wb1.Activate
    ActiveWorkbook.Close SaveChanges:=False

    '###Clear files from combined_data if it exists
    Dim myFilePath2Delete As String:    myFilePath2Delete = "D:\Kibot\Data\!Daily Data (saved as EOD)\Volume-Price Screen\zNuLong_Analysis_Individual\.xlsx"
    If Dir(myFilePath2Delete) <> "" Then
        Kill myFilePath2Delete
    End If

End Sub

我尝试了许多不同的方法来找出解决方案，但是无法使其按我想要的方式工作。我真的不确定如何处理数据，将其粘贴到其他工作簿中，然后继续执行“做循环”，而不会意外结束。

谢谢您的输入。

史蒂芬

Answer 1

我将通过以下方式工作：

Sub mymacro()

Dim objFile As Scripting.File
Dim objFolder As Scripting.Folder
Dim mywb as string

Set objFolder = CreateObject("Shell.Application").Namespace(objFolder.Path)

    'Loop through each file in the folder
    For Each objFile In objFolder.Files

     objFile.Open (objFile.Path)

     mywb = objFile.Name

     Workbooks.Add
     ‘Your code here

    Next objFile

End sub

希望这会有所帮助！

循环时不循环遍历文件夹

1 个答案: