Объединение файлов, в которых может не быть данных в первой ячейке диапазона - PullRequest
Новая
       6

Объединение файлов, в которых может не быть данных в первой ячейке диапазона

0 голосов
/ 13 марта 2020

У меня есть код VBA, который работал. Файлы, которые раньше содержали какие-либо данные в A2 (строка 1 - заголовки). Теперь скрипт пропустит этот файл, если A2 пуст.

В новых версиях файлов есть только те данные, которые мне нужны в A2-AE C. Мне нужно взять все файлы, расположенные в папке, и объединить их в одну электронную таблицу (не несколько вкладок).

Я пробовал искать в нескольких источниках, но не нашел ничего, что работает. 

Sub GatherAndMerge()
Dim wb As Workbook

Dim r As Range
Dim s As String
Const FolderToSearch = "Z:...."  'adjust as desired
s = Dir(FolderToSearch, "\*.xls?")
Do While s <> ""
    If Right(FolderToSearch, 1) <> "\" Then s = "\" & s
    Set wb = Workbooks.Open(FolderToSearch & s)
    Set r = wb.Worksheets(1).UsedRange.Offset(1, 0)
    r.Copy ThisWorkbook.Worksheets(1).Range("a" & Rows.Count).End(xlUp).offset1, 0
    wb.Close False
    s = Dir(0)
Loop
MsgBox "Done"
End Sub

Текущий код. 

Sub simpleXlsMerger()
    Dim bookList As Workbook
    Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
    Application.ScreenUpdating = False
    Set mergeObj = CreateObject("Scripting.FileSystemObject")

    'Set the save path here in the space below between the parentheses
    'The Server is usually mapped to Z but should be verified
    Set dirObj = mergeObj.Getfolder("Z:\path-here")
    Set filesObj = dirObj.Files
    For Each everyObj In filesObj
        Set bookList = Workbooks.Open(everyObj)

        'change "A2" with cell reference of start point for every files here
        'for example "B3:IV" to merge all files start from columns B and rows 3
        'the specified range is much more than the AMMS or Techs should ever send
        Range("A2:IV" & Range("A65536").End(xlUp).Row).Copy
        ThisWorkbook.Worksheets(1).Activate

        'Do not change the following column. It's not the same column as above
        Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
        Application.CutCopyMode = False
        bookList.Close
    Next
End Sub

1 Ответ

1 голос
/ 13 марта 2020 
Sub GatherAndMerge()
Dim wb as workbook

dim r as range
dim s as string
const FolderToSearch = "c:\"  'adjust as desired
s = dir(foldertosearch\*.xls?")
do while s <> ""
if right(foldertosearch,1)<> "\" then  s = "\" & s
set wb = workbooks.open(foldertosearch &  s)
set r = wb.worksheets(1).usedrange.offset(1,0)
r.copy thisworkbook.worksheets(1).range("a" & rows.count).end(xlup).offset(1,0) ' there was a missing bracket here
wb.close False
s = dir(0
loop
Msgbox "Done"
End Sub

Написано на моем телефоне, не лучше, поэтому могут быть опечатки

...