VBA - циклически проходить через файлы в папке, только если выполняется несколько условий - PullRequest
Новая
       0

VBA - циклически проходить через файлы в папке, только если выполняется несколько условий

0 голосов
/ 05 декабря 2018

В настоящее время я использую фрагмент кода для циклического просмотра файлов в папке и копирования определенных ячеек из каждого файла в основной список.Есть несколько файлов, которые добавляются в папку каждую неделю.Один из столбцов в основном списке содержит имена ранее зацикленных файлов.Код перебирает только те файлы, которые не включены в список имен файлов и, следовательно, также не были зациклены ранее.

Я хотел бы расширить это и добавить две корректировки.Я хотел бы, чтобы код копировал дополнительный бит данных, однако на этот раз это диапазон, а не просто ячейка (особенно A20:H33). Когда я пытаюсь изменить код для копирования диапазона, код перестает работать.

Кроме того, я хотел бы копировать данные только из файлов с определенным окончанием имени файла (например, "xxxxFAM"), а также только из файлов, которые еще не были зациклены - будет выбрано это окончание имени файлав ячейке на листе, в который копируются данные.(Ячейка P3 например).Любые идеи о том, как я мог бы сделать это?

Вот код, который я сейчас использую и который был любезно разработан с помощью члена переполнения стека!Обратите внимание, что большая часть моей работы является методом проб и ошибок, см. Ниже предпринятые попытки. 

Option Explicit

Sub CopyFromFolderExample()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim strFolder As String, strFile As String, r As Long, wb As Workbook
Dim varTemp(1 To 6) As Variant

Application.ScreenUpdating = False
strFolder = "D:\Other\folder\"

ws.Range("A4:E" & ws.Rows.Count).ClearContents
r = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

strFile = Dir(strFolder & "*.xl*")
Do While Len(strFile) > 0
    If Not Looped(strFile, ws) Then
        Application.StatusBar = "Reading data from " & strFile & "..."
        Set wb = Workbooks.Add(strFolder & strFile)
        With wb.Worksheets(1)
            varTemp(1) = .Range("A13").Value
            varTemp(2) = .Range("H8").Value
            varTemp(3) = .Range("H9").Value
            varTemp(4) = .Range("H36").Value
            varTemp(5) = .Range("H37").Value
            varTemp(6) = strFile
        End With
        wb.Close False

        r = r + 1
        ws.Range(ws.Cells(r, 1), ws.Cells(r, 6)).Formula = varTemp
    End If    
  strFile = Dir
Loop

Application.StatusBar = False
Application.ScreenUpdating = True

End Sub


Private Function Looped(strFile As String, ws As Worksheet) As Boolean

Dim Found As Range
Set Found = ws.Range("F:F").Find(strFile)

If Found Is Nothing Then
Looped = False
Else
Looped = True
End If

End Function

Вот попытка 1 с использованием Я просто изменитьодин из переменных в диапазон - неудивительно, что это не сработало (без ошибок - диапазон просто не копируется) 

Sub CopyFromFolderExample()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(4)
Dim strFolder As String, strFile As String, r As Long, wb As Workbook
Dim varTemp(1 To 6) As Variant

Application.ScreenUpdating = False
strFolder = "D:\Other\folder\"

'ws.Range("A2:E" & ws.Rows.Count).ClearContents
r = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

strFile = Dir(strFolder & "*.xl*")
Do While Len(strFile) > 0
    If Not Looped(strFile, ws) Then
        Application.StatusBar = "Reading data from " & strFile & "..."
        Set wb = Workbooks.Add(strFolder & strFile)
        With wb.Worksheets(1)
            varTemp(1) = strFile
            varTemp(2) = .Range("A13").Value
            varTemp(3) = .Range("H8").Value
            varTemp(4) = .Range("H9").Value
            varTemp(5) = .Range("H37").Value
            varTemp(6) = .Range("A20:A33").Value

        End With
        wb.Close False

        r = r + 1
        ws.Range(ws.Cells(r, 10), ws.Cells(r, 15)).Formula = varTemp
    End If
  strFile = Dir
Loop

Application.StatusBar = False
Application.ScreenUpdating = True

Вот попытка 2 с использованием selection.copy и selection.paste(«Объект не поддерживает это свойство или метод», ошибка не найдена: 

Sub CopyFromFolderExample()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(4)
Dim strFolder As String, strFile As String, r As Long, wb As Workbook
Dim varTemp(1 To 6) As Variant

Application.ScreenUpdating = False
strFolder = "D:\Other\folder\"

'ws.Range("A2:E" & ws.Rows.Count).ClearContents
r = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

strFile = Dir(strFolder & "*.xl*")
Do While Len(strFile) > 0
    If Not Looped(strFile, ws) Then
        Application.StatusBar = "Reading data from " & strFile & "..."
        Set wb = Workbooks.Add(strFolder & strFile)
        With wb.Worksheets(1)
            varTemp(1) = strFile
            varTemp(2) = .Range("A13").Value
            varTemp(3) = .Range("H8").Value
            varTemp(4) = .Range("H9").Value
            varTemp(5) = .Range("H37").Value

.Range("A20:H33").Select
.Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

ws.Activate

If ws.Range("A1") = "" Then
ws.Range("A1").Select
Selection.Paste
Else
Selection.End(xlDown).Offset(6, 0).Select
Selection.Paste
End If

        End With
        wb.Close False

        r = r + 1
        ws.Range(ws.Cells(r, 10), ws.Cells(r, 15)).Formula = varTemp
    End If
  strFile = Dir
Loop

Application.StatusBar = False
Application.ScreenUpdating = True

Вот попытка 3 с использованием модифицированной подпрограммы, которая включена в основной код :(И диапазон, и ячейки копируются, однако мне не удалось включить это в основной код, поэтому диапазон копируется только при соблюдении условий): 

Sub CopyFromFolderExample()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(4)
Dim strFolder As String, strFile As String, r As Long, wb As Workbook
Dim varTemp(1 To 6) As Variant

Application.ScreenUpdating = False
strFolder = "D:\Other\folder\"

'ws.Range("A2:E" & ws.Rows.Count).ClearContents
r = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

strFile = Dir(strFolder & "*.xl*")
Do While Len(strFile) > 0
    If Not Looped(strFile, ws) Then
        Application.StatusBar = "Reading data from " & strFile & "..."
        Set wb = Workbooks.Add(strFolder & strFile)
        With wb.Worksheets(1)
            varTemp(1) = strFile
            varTemp(2) = .Range("A13").Value
            varTemp(3) = .Range("H8").Value
            varTemp(4) = .Range("H9").Value
            varTemp(5) = .Range("H37").Value
            'varTemp(6) = .Range("A20:A33").Value

        End With
        wb.Close False

        r = r + 1
        ws.Range(ws.Cells(r, 10), ws.Cells(r, 15)).Formula = varTemp
    End If
  strFile = Dir
Loop

Application.StatusBar = False
Application.ScreenUpdating = True

Dim xRg As Range
Dim xSelItem As Variant
Dim xFileDlg As FileDialog
Dim xFileName, xSheetName, xRgStr As String
Dim xBook, xWorkBook As Workbook
Dim xSheet As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "DELIVERY NOTE"
xRgStr = "A20:H33"
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
With xFileDlg
    If .Show = -1 Then
        xSelItem = .SelectedItems.Item(1)
        Set xWorkBook = ThisWorkbook
        Set xSheet = xWorkBook.Sheets("DN Compile")
        If xSheet Is Nothing Then

xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets ---> 
--->(xWorkBook.Worksheets.Count)).Name = "DN Compile"
            Set xSheet = xWorkBook.Sheets("DN Compile")
        End If
        xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
        If xFileName = "" Then Exit Sub
        Do Until xFileName = ""
           Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
            Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
            xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
            xFileName = Dir()
            xBook.Close
        Loop
    End If
End With
Application.DisplayAlerts = True
Application.EnableEvents = True

Application.ScreenUpdating = True
End Sub


Private Function Looped(strFile As String, ws As Worksheet) As Boolean

Dim Found As Range
Set Found = ws.Range("A:A").Find(strFile)

If Found Is Nothing Then
Looped = False
Else
Looped = True
End If

End Function

1 Ответ

0 голосов
/ 06 декабря 2018

Я столкнулся с подобной проблемой при копировании диапазона в массив.Что было исправлено, так это использование .Value2 вместо .Value.Может стоит попробовать.

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...