Делать, пока цикл не проходит через папку - PullRequest
Новая
       8

Делать, пока цикл не проходит через папку

0 голосов
/ 01 октября 2018

У меня есть около 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

Я пробовал так много разных способов найти решение, но не смог заставить его работать так, как нужно.Я хочу.Я действительно не уверен в том, как обрабатывать данные, вставлять их в другую рабочую книгу, а затем выполнять цикл «пока-в-цикле» без неожиданного завершения.

Заранее благодарю за любой ввод.

Стивен

1 Ответ

0 голосов
/ 01 октября 2018

Я поработаю над чем-то вроде этого: 

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

надеюсь, это поможет !!

...