Копирование данных из множества книг XL в одну

[Z0RGE]

Доброго времени суток!
Помогите, пожалуйста, очень надо по работе!
Начальство сказало для упрощения жизни сотрудников (но явно не моей) сделать макрос, а я в этом ничего не понимаю, не хотелось бы ударить в грязь лицом перед начальством!
В общем суть в следующем:
Имеется папка в которую в течение квартала будут размещаться файлы (много) с данными (во вложении папка "исходные данные"). Нужно копировать необходимые данные из всех файлов в один файл (во вложении "Результат")
И копировать данные нужно из соответствующих граф файлов "исходных данных" в соответствующие графы файла "Результат".

В файле "Результат" 3 листа:
1 - На нем нужно разместить кнопку макроса.
2 - На нем нужно что бы заполнялись соответствующей информацией ячейки выделенные зеленым
3 - На нем нужно что бы заполнялись соответствующей информацией ячейки выделенные зеленым

Вот такой макрос мне необходим, помогите пожалуйста!

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

[Hugo121]

Доброго!
По задаче - это Ужос...
Буду удивлён, если найдётся энтузиаст бороться с этими объединениями даже после Ваших подробных объяснений что куда нужно копировать.
Готовьте деньги... Я не претендую - т.к. столько не заплатите.

P.S. Может быть есть другие исходные данные? Ну не изготавливаете ведь эти акты каждый индивидуально вручную? Или всёж вручную? Ужос...

[EducatedFool]

я в этом ничего не понимаю, не хотелось бы ударить в грязь лицом перед начальством

а что мешает разобраться?
самостоятельно пробовали что-нибудь сделать?

Если по работе, от вас не требуется знание макросов, - так и скажите начальству
А если требуется, а вы не знаете, - есть повод заняться изучением
Ну а если же хочется показать всем, как вы круто автоматизируете работу, при этом не потратив времени и сил на написание макроса, — надо платить...

Бесплатно тут ПОМОГАЮТ разобраться в ВАШЕМ решении. А если делать готовое решение «с нуля» — как верно заметил Hugo121, вряд ли будет толпа желающих.

[Z0RGE]

По работе, не требуется, но при нынешнем времени... приходится делать, что просят...

Акты стандартной формы... заполняются вручную...

Подскажите, сколько может стоить создание данного макроса?

Спасибо.

[Z0RGE]

Есть такой макрос, может его можно как-то использовать

Sub kassrabota()

Dim FSO, TheFolder, TheFiles, AFile, wb1 As Workbook
Dim tarr(), arr()
Dim papki As New Collection
Dim i As Long
Dim q As Long
Dim s As Long
Dim p As Long
Dim m As Long
Dim r As Long
Dim v As Long
Dim y As Long
Dim e As Long
Dim k As Long

Dim intX As Integer
'Application.ScreenUpdating = False

wb = ActiveWorkbook.Name

Set FSO = CreateObject("Scripting.FileSystemObject")
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False

intX = MsgBox("Все ранее загруженные данные в этом файле будут удалены. Вы согласны?", vbYesNo)
If intX = vbYes Then

Sheets("Отчет").Select
Range(Cells(10, 1), Cells(10, 21)).ClearContents
Range(Cells(11, 1), Cells(300000, 21)).Delete

Sheets("ТБ").Select
Range(Cells(15, 1), Cells(15, 4)).ClearContents
Range(Cells(4, 2), Cells(10, 2)).ClearContents
Range(Cells(16, 1), Cells(300000, 4)).Delete

'Sheets("Среднее_время").Activate

ReDim arr(7, 1)
ReDim tarr(200000, 4)
ReDim tarr2(200000, 21)

With Application.FileDialog(msoFileDialogFolderPicker)
   .Title = "Выберите папку, в которой сохранены отчеты ГОСБ по ошибкам по кассовой работе"
   .Show
   If .SelectedItems.Count = 0 Then
Exit Sub
   End If
   Path = .SelectedItems(1)
   End With


Set TheFolder = FSO.GetFolder(Path & "\")
Set TheFiles = TheFolder.Files
m = 0
r = 0
For Each AFile In TheFiles
Set xls = Workbooks.Open(Filename:=AFile, ReadOnly:=True)
s = 0
'i = i + 1
Sheets("ГОСБ").Select
For s = 1 To 7
arr(s, 1) = arr(s, 1) + Range(Cells(s + 4, 2), Cells(s + 4, 2)).Value
Next s

o = Cells(1, 22).Value
p = 0
For p = 1 To o
tarr(m + p, 4) = Range(Cells(p + 15, 1), Cells(p + 15, 4))
Next p
m = m + o

Sheets("Отчет").Select

v = Cells(5, 22).Value
y = 0
For y = 1 To v
tarr2(r + y, 21) = Range(Cells(y + 9, 1), Cells(y + 9, 21))
Next y
r = r + v

xls.Close False
Next

Workbooks(wb).Activate
Sheets("ТБ").Select

For w = 1 To 7
Range(Cells(w + 3, 2), Cells(w + 3, 2)) = arr(w, 1)
Next w

e = 0
For e = 1 To m
Range(Cells(e + 14, 1), Cells(e + 14, 4)) = tarr(e, 4)
Next e


Range(Cells(15, 1), Cells(15, 4)).Copy
Range(Cells(16, 1), Cells(m + 14, 4)).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False

'Range(Cells(1, 5), Cells(1, 5)) = m
'Range(Cells(2, 5), Cells(2, 5)) = r
'Range(Cells(3, 5), Cells(3, 5)) = o
'Range(Cells(4, 5), Cells(4, 5)) = v

Sheets("Отчет").Select

k = 0
For k = 1 To r
Range(Cells(k + 9, 1), Cells(k + 9, 21)) = tarr2(k, 21)
Next k

Range(Cells(10, 1), Cells(10, 21)).Copy
Range(Cells(11, 1), Cells(r + 9, 21)).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False

Else

MsgBox "Загрузка файлов отменена"
End If

Application.AskToUpdateLinks = True
Application.DisplayAlerts = True

End Sub

[Hugo121]

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

Ну а по цене думаю так - берёте примерно часовую ставку специалиста, умножаете на 2 (т.к. тут нужно не на форуме сидеть, а работать, причём обычно в свой выходной), ну а дальше надеюсь понимаете, что за 10 минут эту задачу никто не напишет. И за час думаю тоже...
Т.е. в итоге где-то на дневной заработок можно ориентироваться - это если до начала работы будет совершенно понятно что куда нужно копировать, чтоб не тратить время ещё и на выяснение этих моментов.

Хотя вот по объединениям есть одна мысль - попробуйте на источнике выполнить такой код и тянуть данные из результата этой работы

Sub tt()
    Dim c As Range, cc As Range, cm As Range, x
    Application.ScreenUpdating = False
    For Each c In ActiveSheet.UsedRange.Offset(31).Cells
        If c.MergeCells Then
            x = c(1)
            Set cm = Range(c.MergeArea.Address)
            c.UnMerge
            For Each cc In cm
                cc = x
            Next
        End If
    Next
    Application.ScreenUpdating = True
End Sub

И кстати где-то полчаса уже на эту работу потрачено...

[Z0RGE]

Ясно... даже не знаю, что делать... подумаю, может откажусь...
А возможно и легче будет поменять форму Акта...
В любом случае спасибо за помощь!