Excel VBA вручную выбирает папку для зацикливания всех файлов Excel в ней - PullRequest
Новая
       16

Excel VBA вручную выбирает папку для зацикливания всех файлов Excel в ней

0 голосов
/ 03 мая 2018

У меня есть следующий код VBA, чтобы просмотреть все файлы Excel в папке и скопировать необходимые столбцы из всех файлов в один. Вот код: 

    Option Explicit

    Const FOLDER_PATH = "C:\Users\user\Desktop\04. April 2018\"

Sub ImportIncidentWorksheets()
Dim sFile As String
Dim wsTarget As Worksheet
Dim wbsource As Workbook
Dim wsSource As Worksheet
Dim rowTarget As Long
Dim rowSource As Long


rowTarget = 2

If Not FileFolderExists(FOLDER_PATH) Then
MsgBox "Specified folder does not exist, exiting!"
Exit Sub
End If
On Error GoTo errHandler
Application.ScreenUpdating = True

Set wsTarget = Sheets("SC")
sFile = Dir(FOLDER_PATH & "*.xlsx*")
Do Until sFile = ""

Set wbsource = Workbooks.Open(FOLDER_PATH & sFile)
Set wsSource = wbsource.Worksheets("sheet1")
With wsSource
rowSource = Application.Max(.Range("A" & .Rows.Count).End(xlUp).Row, .Range("B" & .Rows.Count).End(xlUp).Row, .Range("C" & .Rows.Count).End(xlUp).Row, .Range("D" & .Rows.Count).End(xlUp).Row, .Range("E" & .Rows.Count).End(xlUp).Row)
End With
With wsTarget

.Range("A" & rowTarget & ":E" & rowTarget + rowSource - 2).Value = wsSource.Range("A2:E" & rowSource).Value
 .Range("A" & rowTarget & ":C" & rowTarget + rowSource - 2).Value = wsSource.Range("A2:C" & rowSource).Value
 .Range("D" & rowTarget & ":D" & rowTarget + rowSource - 2).Value = wsSource.Range("E2:E" & rowSource).Value
 .Range("E" & rowTarget & ":E" & rowTarget + rowSource - 2).Value = wsSource.Range("D2:D" & rowSource).Value
 .Range("F" & rowTarget).Value = wbsource.Name


End With

wbsource.Close SaveChanges:=False
rowTarget = rowTarget + rowSource - 1
sFile = Dir()
Loop

errHandler:
On Error Resume Next
Application.ScreenUpdating = True


Set wsSource = Nothing
Set wbsource = Nothing
Set wsTarget = Nothing

End Sub
Private Function FileFolderExists(strPath As String) As Boolean
If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True

End Function

Как мне изменить первую часть, чтобы путь к папке не был жестко запрограммирован, но у меня появилось всплывающее окно, и я мог выбрать папку вручную?

1 Ответ

0 голосов
/ 03 мая 2018

Вы можете использовать код, как показано ниже, чтобы получить путь при выполнении кода. 

Dim strFolderPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Show
    If .SelectedItems.Count <> 0 Then
        strFolderPath = .SelectedItems(1)
    Else
        MsgBox "Path not selected!", vbExclamation
    End If
End With
...