Здравствуйте. Есть макрос, который прекрасно работает, если надо из однотипных файлов в одной папке скопировать заданный диапазон. Но, возникла проблема, которую сам решить не могу (макрос также был найден на просторах).
При копирование 1 строки все ОК, но если задать в диапазоне 2 или больше, то при копирование из всех последующих после первого файла, данные накладываются друг на дружку. Таким образом полный диапазон копируется только с последнего файла. Как сделать так, чтобы диапазон со второго файла вставлялся после данных из первого, а не накладывался, вставляясь во вторую строку.
При копирование 1 строки все ОК, но если задать в диапазоне 2 или больше, то при копирование из всех последующих после первого файла, данные накладываются друг на дружку. Таким образом полный диапазон копируется только с последнего файла. Как сделать так, чтобы диапазон со второго файла вставлялся после данных из первого, а не накладывался, вставляясь во вторую строку.
Скрытый текст |
---|
Public colfile() As String Public cd Sub fold() Dim objShell As Object Dim objFolder As Object Dim strFolderFullPath As String start: Set objShell = CreateObject("Shell.Application") Set objFolder = objShell.BrowseForFolder(0&, "Папка", BIF_RETURNONLYFSDIRS, InitialFolder) If (Not objFolder Is Nothing) Then On Error Resume Next If IsError(objFolder.items.Item.Path) Then strFolderFullPath = CStr(objFolder): GoTo here On Error GoTo 0 If Len(objFolder.items.Item.Path) > 3 Then strFolderFullPath = objFolder.items.Item.Path & Application.PathSeparator Else strFolderFullPath = objFolder.items.Item.Path End If Else Select Case MsgBox("Папка для просмотра не выбрана? Повторить", vbQuestion + vbOKCancel, "Папка не выбрана") Case vbOK: GoTo start Case vbCancel: Exit Sub End Select End If here: dest strFolderFullPath Set ws = ThisWorkbook.Worksheets("Продажа") Set xls = CreateObject("Excel.Application") xls.DisplayAlerts = False For i = 1 To UBound(colfile) - 1 Set xlb = xls.Workbooks.Open(colfile(i)) Set xl = xlb.Worksheets(2) xl.Range(xl.Cells(3, 1), xl.Cells(6, 19)).Copy ws.Activate ws.Cells(i + 1, 3).Select ws.Paste ws.Cells(i + 1, 1) = colfile(i) xlb.Close Next i End Sub Sub dest(Optional ByVal FolderPath As String = "c:\") On Error Resume Next Set fso = CreateObject("Scripting.FileSystemObject") Set f = fso.GetFolder(FolderPath) ReDim colfile(1) For Each fl In f.Files ' If Mid(fl.Name, InStr(1, fl.Name, ".", vbTextCompare) + 1, Len(fl.Name) - InStr(1, fl.Name, ".", vbTextCompare)) = "xls" Or Mid(fl.Name, InStr(1, fl.Name, ".", vbTextCompare) + 1, Len(fl.Name) - InStr(1, fl.Name, ".", vbTextCompare)) = "xlsx" Then ReDim Preserve colfile(UBound(colfile) + 1) colfile(UBound(colfile) - 1) = fl ' End If Next End Sub |