Динамическая настройка пути при переносе файла с макросом

@AntonyHopkins · Регистрация: 13.11.2014

Author24 — интернет-сервис помощи студентам

Visual Basic

Sub Ñáîð_äàííûõ()
 
Workbooks.Open Filename:="C:\Users\e.lvova\Desktop\Íîâàÿ ïî ðàéîíàì\Áàãðàòèîíîâñêèé(íîâàÿ).xls"
 
 
 
Workbooks("Áàãðàòèîíîâñêèé(íîâàÿ).xls").Worksheets("Ââîä çåìëè").Range("C30:F30").Copy
 
Workbooks("ñâîäíàÿ.xls").Activate
 
 
ActiveWorkbook.Worksheets("Ââîä çåìëè").Range("C7:F7").PasteSpecial xlPasteValues
 
Workbooks("Áàãðàòèîíîâñêèé(íîâàÿ).xls").Close
 
End Sub

Как избавиться от пути чтобы можно было кидать сводный файл на любом компе в любую папку

@mc-black · 27.11.2014, 17:14

К текущему файлу обращаться: ThisWorkbook, вместо Workbooks("бла-бла-бла.xls"). У текущей книги есть свойство: ThisWorkbook.Path - это полный путь к папке, в которой находится свод (с макросом). Например,

Visual Basic

1
2
3

Dim srcWB As Workbook
Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\" & "Багратионовский(новая).xls")
MsgBox srcWB.Worksheets(1).Cells(1,1) ' Вывод значения A1 на первом листе книги

Добавлено через 17 минут
Вот так по очереди открыть все книги внутри папке со сводом, кроме самого свода (который в данный открыт и содержит этот макрос):

Visual Basic

Option Explicit
 
Sub EnumThisPath()
    Dim MyPath As String, MyName As String, wbk As Workbook
    
    MyPath = ThisWorkbook.Path & "\"
    
    MyName = Dir(MyPath & "*.xls*", vbNormal)
    Do While MyName <> ""
        If (GetAttr(MyPath & MyName) And vbNormal) = vbNormal Then
        If MyName Like "*.xls*" Then ' Перечислить книги Excel
        If Not MyName Like ThisWorkbook.Name Then ' Пропустить текущую книгу
            Set wbk = Workbooks.Open(MyPath & MyName)
            
            Call EnumWorksheets(wbk)
            wbk.Close False
            
            Set wbk = Nothing
        End If
        End If
        End If
        MyName = Dir
    Loop
End Sub
 
Private Sub EnumWorksheets(srcWB As Workbook)
    ' Здесь делаем всё, что надо с открытой книгой
    MsgBox srcWB.Name
End Sub

@AntonyHopkins · 28.11.2014, 10:49 **[ТС]**

И таких 13 районов

Visual Basic

Workbooks.Open (ThisWorkbook.Path & "\" & "Багратионовский(новая).xls")
 
Workbooks("Багратионовский(новая).xls").Worksheets("Ввод земли").Range("C30:F30").Copy
Workbooks("сводная.xls").Activate
ActiveWorkbook.Worksheets("Ввод земли").Range("C7:F7").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Гибель и подкормка").Range("C30:AC30").Copy
Workbooks("сводная.xls").Activate
Worksheets("Гибель и подкормка").Range("C7:AC7").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Яровой сев (без пересева)").Range("C30:CQ30").Copy
Workbooks("сводная.xls").Activate
Worksheets("Яровой сев (без пересева)").Range("C7:CQ7").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Озимый сев").Range("C30:Z30").Copy
Workbooks("сводная.xls").Activate
Worksheets("Озимый сев").Range("C7:Z7").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Заготовка кормов").Range("C30:AS30").Copy
Workbooks("сводная.xls").Activate
Worksheets("Заготовка кормов").Range("C7:AS7").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Уборка урожая").Range("C30:DH30").Copy
Workbooks("сводная.xls").Activate
Worksheets("Уборка урожая").Range("C7:DH7").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Овощи открытого грунта").Range("C30:DB30").Copy
Workbooks("сводная.xls").Activate
Worksheets("Овощи открытого грунта").Range("C7:DB7").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Овощи закрытого грунта").Range("C30:X30").Copy
Workbooks("сводная.xls").Activate
Worksheets("Овощи закрытого грунта").Range("C7:X7").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Плод. и ягод. культуры").Range("C30:T30").Copy
Workbooks("сводная.xls").Activate
Worksheets("Плод. и ягод. культуры").Range("C7:T7").PasteSpecial xlPasteValues
 
Workbooks("Багратионовский(новая).xls").Worksheets("Ввод земли").Range("C60:F60").Copy
Workbooks("сводная.xls").Activate
ActiveWorkbook.Worksheets("Ввод земли").Range("C8:F8").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Гибель и подкормка").Range("C60:AC60").Copy
Workbooks("сводная.xls").Activate
Worksheets("Гибель и подкормка").Range("C8:AC8").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Яровой сев (без пересева)").Range("C60:CQ60").Copy
Workbooks("сводная.xls").Activate
Worksheets("Яровой сев (без пересева)").Range("C8:CQ8").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Озимый сев").Range("C60:Z60").Copy
Workbooks("сводная.xls").Activate
Worksheets("Озимый сев").Range("C8:Z8").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Заготовка кормов").Range("C60:AS60").Copy
Workbooks("сводная.xls").Activate
Worksheets("Заготовка кормов").Range("C8:AS8").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Уборка урожая").Range("C60:DH60").Copy
Workbooks("сводная.xls").Activate
Worksheets("Уборка урожая").Range("C8:DH8").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Овощи открытого грунта").Range("C60:DB60").Copy
Workbooks("сводная.xls").Activate
Worksheets("Овощи открытого грунта").Range("C8:DB8").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Овощи закрытого грунта").Range("C60:X60").Copy
Workbooks("сводная.xls").Activate
Worksheets("Овощи закрытого грунта").Range("C8:X8").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Плод. и ягод. культуры").Range("C60:T60").Copy
Workbooks("сводная.xls").Activate
Worksheets("Плод. и ягод. культуры").Range("C8:T8").PasteSpecial xlPasteValues
 
Workbooks("Багратионовский(новая).xls").Worksheets("Ввод земли").Range("C61:F61").Copy
Workbooks("сводная.xls").Activate
ActiveWorkbook.Worksheets("Ввод земли").Range("C9:F9").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Гибель и подкормка").Range("C61:AC61").Copy
Workbooks("сводная.xls").Activate
Worksheets("Гибель и подкормка").Range("C9:AC9").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Яровой сев (без пересева)").Range("C61:CQ61").Copy
Workbooks("сводная.xls").Activate
Worksheets("Яровой сев (без пересева)").Range("C9:CQ9").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Озимый сев").Range("C61:Z61").Copy
Workbooks("сводная.xls").Activate
Worksheets("Озимый сев").Range("C9:Z9").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Заготовка кормов").Range("C61:AS61").Copy
Workbooks("сводная.xls").Activate
Worksheets("Заготовка кормов").Range("C9:AS9").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Уборка урожая").Range("C61:DH61").Copy
Workbooks("сводная.xls").Activate
Worksheets("Уборка урожая").Range("C9:DH9").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Овощи открытого грунта").Range("C61:DB61").Copy
Workbooks("сводная.xls").Activate
Worksheets("Овощи открытого грунта").Range("C9:DB9").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Овощи закрытого грунта").Range("C61:X61").Copy
Workbooks("сводная.xls").Activate
Worksheets("Овощи закрытого грунта").Range("C9:X9").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Плод. и ягод. культуры").Range("C61:T61").Copy
Workbooks("сводная.xls").Activate
Worksheets("Плод. и ягод. культуры").Range("C9:T9").PasteSpecial xlPasteValues
 
Workbooks("Багратионовский(новая).xls").Worksheets("Ввод земли").Range("C62:F62").Copy
Workbooks("сводная.xls").Activate
ActiveWorkbook.Worksheets("Ввод земли").Range("C10:F10").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Гибель и подкормка").Range("C62:AC62").Copy
Workbooks("сводная.xls").Activate
Worksheets("Гибель и подкормка").Range("C10:AC10").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Яровой сев (без пересева)").Range("C62:CQ62").Copy
Workbooks("сводная.xls").Activate
Worksheets("Яровой сев (без пересева)").Range("C10:CQ10").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Озимый сев").Range("C62:Z62").Copy
Workbooks("сводная.xls").Activate
Worksheets("Озимый сев").Range("C10:Z10").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Заготовка кормов").Range("C62:AS62").Copy
Workbooks("сводная.xls").Activate
Worksheets("Заготовка кормов").Range("C10:AS10").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Уборка урожая").Range("C62:DH62").Copy
Workbooks("сводная.xls").Activate
Worksheets("Уборка урожая").Range("C10:DH10").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Овощи открытого грунта").Range("C62:DB62").Copy
Workbooks("сводная.xls").Activate
Worksheets("Овощи открытого грунта").Range("C10:DB10").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Овощи закрытого грунта").Range("C62:X62").Copy
Workbooks("сводная.xls").Activate
Worksheets("Овощи закрытого грунта").Range("C10:X10").PasteSpecial xlPasteValues
Workbooks("Багратионовский(новая).xls").Worksheets("Плод. и ягод. культуры").Range("C62:T62").Copy
Workbooks("сводная.xls").Activate
Worksheets("Плод. и ягод. культуры").Range("C10:T10").PasteSpecial xlPasteValues
 
 
Workbooks("Багратионовский(новая).xls").Close

Потом вставка увеличивается на 5!

@~~Апострофф~~ · 28.11.2014, 10:54

Сообщение от AntonyHopkins

И таких 13 районов

А код для всех одинаковый?

@AntonyHopkins · 28.11.2014, 10:59 **[ТС]**

Написал но говорит что большая процедура! Что делать! файл не закрывается!
Там 13 районов по 5 строк на район.

@AntonyHopkins · 28.11.2014, 11:09 **[ТС]**

Вот выложил код! меняется только откуда взять(имя файла), где поставить(номера строк на 5 смещаются для каждого файла)

Добавлено через 8 минут

Visual Basic

Workbooks.Open (ThisWorkbook.Path & "\" & "Гвардейский(новая).xls")
 
Workbooks("Гвардейский(новая).xls").Worksheets("Ввод земли").Range("C30:F30").Copy
Workbooks("сводная.xls").Activate
ActiveWorkbook.Worksheets("Ввод земли").Range("C12:F12").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Гибель и подкормка").Range("C30:AC30").Copy
Workbooks("сводная.xls").Activate
Worksheets("Гибель и подкормка").Range("C12:AC12").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Яровой сев (без пересева)").Range("C30:CQ30").Copy
Workbooks("сводная.xls").Activate
Worksheets("Яровой сев (без пересева)").Range("C12:CQ12").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Озимый сев").Range("C30:Z30").Copy
Workbooks("сводная.xls").Activate
Worksheets("Озимый сев").Range("C12:Z12").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Заготовка кормов").Range("C30:AS30").Copy
Workbooks("сводная.xls").Activate
Worksheets("Заготовка кормов").Range("C12:AS12").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Уборка урожая").Range("C30:DH30").Copy
Workbooks("сводная.xls").Activate
Worksheets("Уборка урожая").Range("C12:DH12").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Овощи открытого грунта").Range("C30:DB30").Copy
Workbooks("сводная.xls").Activate
Worksheets("Овощи открытого грунта").Range("C12:DB12").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Овощи закрытого грунта").Range("C30:X30").Copy
Workbooks("сводная.xls").Activate
Worksheets("Овощи закрытого грунта").Range("C12:X12").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Плод. и ягод. культуры").Range("C30:T30").Copy
Workbooks("сводная.xls").Activate
Worksheets("Плод. и ягод. культуры").Range("C12:T12").PasteSpecial xlPasteValues
 
Workbooks("Гвардейский(новая).xls").Worksheets("Ввод земли").Range("C60:F60").Copy
Workbooks("сводная.xls").Activate
ActiveWorkbook.Worksheets("Ввод земли").Range("C13:F13").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Гибель и подкормка").Range("C60:AC60").Copy
Workbooks("сводная.xls").Activate
Worksheets("Гибель и подкормка").Range("C13:AC13").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Яровой сев (без пересева)").Range("C60:CQ60").Copy
Workbooks("сводная.xls").Activate
Worksheets("Яровой сев (без пересева)").Range("C13:CQ13").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Озимый сев").Range("C60:Z60").Copy
Workbooks("сводная.xls").Activate
Worksheets("Озимый сев").Range("C13:Z13").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Заготовка кормов").Range("C60:AS60").Copy
Workbooks("сводная.xls").Activate
Worksheets("Заготовка кормов").Range("C13:AS13").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Уборка урожая").Range("C60:DH60").Copy
Workbooks("сводная.xls").Activate
Worksheets("Уборка урожая").Range("C13:DH13").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Овощи открытого грунта").Range("C60:DB60").Copy
Workbooks("сводная.xls").Activate
Worksheets("Овощи открытого грунта").Range("C13:DB13").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Овощи закрытого грунта").Range("C60:X60").Copy
Workbooks("сводная.xls").Activate
Worksheets("Овощи закрытого грунта").Range("C13:X13").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Плод. и ягод. культуры").Range("C60:T60").Copy
Workbooks("сводная.xls").Activate
Worksheets("Плод. и ягод. культуры").Range("C13:T13").PasteSpecial xlPasteValues
 
Workbooks("Гвардейский(новая).xls").Worksheets("Ввод земли").Range("C61:F61").Copy
Workbooks("сводная.xls").Activate
ActiveWorkbook.Worksheets("Ввод земли").Range("C14:F14").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Гибель и подкормка").Range("C61:AC61").Copy
Workbooks("сводная.xls").Activate
Worksheets("Гибель и подкормка").Range("C14:AC14").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Яровой сев (без пересева)").Range("C61:CQ61").Copy
Workbooks("сводная.xls").Activate
Worksheets("Яровой сев (без пересева)").Range("C14:CQ14").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Озимый сев").Range("C61:Z61").Copy
Workbooks("сводная.xls").Activate
Worksheets("Озимый сев").Range("C14:Z14").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Заготовка кормов").Range("C61:AS61").Copy
Workbooks("сводная.xls").Activate
Worksheets("Заготовка кормов").Range("C14:AS14").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Уборка урожая").Range("C61:DH61").Copy
Workbooks("сводная.xls").Activate
Worksheets("Уборка урожая").Range("C14:DH14").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Овощи открытого грунта").Range("C61:DB61").Copy
Workbooks("сводная.xls").Activate
Worksheets("Овощи открытого грунта").Range("C14:DB14").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Овощи закрытого грунта").Range("C61:X61").Copy
Workbooks("сводная.xls").Activate
Worksheets("Овощи закрытого грунта").Range("C14:X14").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Плод. и ягод. культуры").Range("C61:T61").Copy
Workbooks("сводная.xls").Activate
Worksheets("Плод. и ягод. культуры").Range("C14:T14").PasteSpecial xlPasteValues
 
Workbooks("Гвардейский(новая).xls").Worksheets("Ввод земли").Range("C62:F62").Copy
Workbooks("сводная.xls").Activate
ActiveWorkbook.Worksheets("Ввод земли").Range("C15:F15").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Гибель и подкормка").Range("C62:AC62").Copy
Workbooks("сводная.xls").Activate
Worksheets("Гибель и подкормка").Range("C15:AC15").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Яровой сев (без пересева)").Range("C62:CQ62").Copy
Workbooks("сводная.xls").Activate
Worksheets("Яровой сев (без пересева)").Range("C15:CQ15").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Озимый сев").Range("C62:Z62").Copy
Workbooks("сводная.xls").Activate
Worksheets("Озимый сев").Range("C15:Z15").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Заготовка кормов").Range("C62:AS62").Copy
Workbooks("сводная.xls").Activate
Worksheets("Заготовка кормов").Range("C15:AS15").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Уборка урожая").Range("C62:DH62").Copy
Workbooks("сводная.xls").Activate
Worksheets("Уборка урожая").Range("C15:DH15").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Овощи открытого грунта").Range("C62:DB62").Copy
Workbooks("сводная.xls").Activate
Worksheets("Овощи открытого грунта").Range("C15:DB15").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Овощи закрытого грунта").Range("C62:X62").Copy
Workbooks("сводная.xls").Activate
Worksheets("Овощи закрытого грунта").Range("C15:X15").PasteSpecial xlPasteValues
Workbooks("Гвардейский(новая).xls").Worksheets("Плод. и ягод. культуры").Range("C62:T62").Copy
Workbooks("сводная.xls").Activate
Worksheets("Плод. и ягод. культуры").Range("C15:T15").PasteSpecial xlPasteValues
 
 
Workbooks("Гвардейский(новая).xls").Close

@mc-black · 28.11.2014, 11:21

Жесть конечно

Но попытка засчитана! Спагетти-стайл.
Процедуру можно разбить на 2-3 примерно равные, чтобы проверить, работает ли оно? И если работает, то довольствоваться пока этим и улучшать. Но вообще, программирование оно как раз заключается в том, чтобы нагромождения частных моментов заменять изящными сокращениями. В вашем большом коде очень много текстовых данных, которые придется править, если сползет какое-то название так же долго, как вы это сооружали. Смотрите. В сводный файл можно на отдельный лист занести всю эту массу текста, при этом структуриров её в виде какой-то осмысленной таблицы. Лист потом можно скрыть, никто кроме вас его не увидит. И затем написать очень короткий макрос, который пройдется по вспомогательному листу и выполнит инструкции парой-тройкой вложенных циклов и небольшим набором условного ветвления if.

@~~Апострофф~~ · 28.11.2014, 11:41

Visual Basic

with Workbooks.Open (ThisWorkbook.Path & "\" & "Багратионовский(новая).xls")
Workbooks("сводная.xls").Activate
Worksheets("Ввод земли").Range("C7:F7").value=.Worksheets("Ввод земли").Range("C30:F30").value
Worksheets("Гибель и подкормка").Range("C7:AC7").value=.Worksheets("Гибель и подкормка").Range("C30:AC30").value
'и т.д.
.Close
end with

Только благодаря этому ~ в три раза уменьшится к-во строк.
А если сделать цикл по районам - считайте сами.

Добавлено через 26 минут
Цикл как-то так (не проверял)

Visual Basic

a=array("\Багратионовский(новая).xls","\Гвардейский(новая).xls","\Гурьевский(новая).xls") 'продолжите список файлов сами
for i=0 to ubound(a)
  with Workbooks.Open (ThisWorkbook.Path & a(i))
    Workbooks("сводная.xls").Activate
    Worksheets("Ввод земли").Range("C7:F7").offset(5*i).value=.Worksheets("Ввод земли").Range("C30:F30").value
    Worksheets("Гибель и подкормка").Range("C7:AC7").offset(5*i).value=.Worksheets("Гибель и подкормка").Range("C30:AC30").value
    'и т.д.
    .Close
  end with
next i

@AntonyHopkins · 28.11.2014, 11:44 **[ТС]**

Visual Basic

With Workbooks.Open(ThisWorkbook.Path & "\" & "Багратионовский(новая).xls")
 
Workbooks("сводная.xls").Activate
Worksheets("Ввод земли").Range("C7:F7").Value = .Worksheets("Ввод земли").Range("C30:F30").Value
Worksheets("Гибель и подкормка").Range("C7:AC7").Value = .Worksheets("Гибель и подкормка").Range("C30:AC30").Value
Worksheets("Яровой сев (без пересева)").Range("C7:CQ7").Value = .Worksheets("Яровой сев (без пересева)").Range("C30:CQ30").Value
Worksheets("Озимый сев").Range("C7:Z7").Value = .Worksheets("Озимый сев").Range("C30:Z30").Value
Worksheets("Заготовка кормов").Range("C7:AS7").Value = .Worksheets("Заготовка кормов").Range("C30:AS30").Value
Worksheets("Уборка урожая").Range("C7:DH7").Value = .Worksheets("Уборка урожая").Range("C30:DH30").Value
Worksheets("Овощи открытого грунта").Range("C7:DB7").Value = .Worksheets("Овощи открытого грунта").Range("C30:DB30").Value
Worksheets("Овощи закрытого грунта").Range("C7:X7").Value = .Worksheets("Овощи закрытого грунта").Range("C30:X30").Value
Worksheets("Плод. и ягод. культуры").Range("C7:T7").Value = .Worksheets("Плод. и ягод. культуры").Range("C30:T30").Value
 
.Close
End With

Как цикл сделать там где "7" надо сделать 8,9,10 а там где "30" 60,61,62

@AntonyHopkins · 28.11.2014, 11:47 **[ТС]**

Visual Basic

With Workbooks.Open(ThisWorkbook.Path & "\" & "Багратионовский(новая).xls")
 
Workbooks("сводная.xls").Activate
Worksheets("Ввод земли").Range("C7:F7").Value = .Worksheets("Ввод земли").Range("C30:F30").Value
Worksheets("Гибель и подкормка").Range("C7:AC7").Value = .Worksheets("Гибель и подкормка").Range("C30:AC30").Value
Worksheets("Яровой сев (без пересева)").Range("C7:CQ7").Value = .Worksheets("Яровой сев (без пересева)").Range("C30:CQ30").Value
Worksheets("Озимый сев").Range("C7:Z7").Value = .Worksheets("Озимый сев").Range("C30:Z30").Value
Worksheets("Заготовка кормов").Range("C7:AS7").Value = .Worksheets("Заготовка кормов").Range("C30:AS30").Value
Worksheets("Уборка урожая").Range("C7:DH7").Value = .Worksheets("Уборка урожая").Range("C30:DH30").Value
Worksheets("Овощи открытого грунта").Range("C7:DB7").Value = .Worksheets("Овощи открытого грунта").Range("C30:DB30").Value
Worksheets("Овощи закрытого грунта").Range("C7:X7").Value = .Worksheets("Овощи закрытого грунта").Range("C30:X30").Value
Worksheets("Плод. и ягод. культуры").Range("C7:T7").Value = .Worksheets("Плод. и ягод. культуры").Range("C30:T30").Value
 
.Close
End With

Все супер! Как цикл сделать там где "7" надо сделать 8,9,10 а там где "30" 60,61,62 по очереди!

shanemac51 · 28.11.2014, 11:54

этот код в 2 с половиной раза меньше вашего
если можно использовать 1 имя вместо двух разница будет более 3 раз
если есть закономерность в значении ранге для разных районов ---разница еще больше

хотя
я видимо изменила структуру рабочего листа(перевела в столбик )
имя книги,все остальные столбики
...........
..........
и делала сводную на рабочий лист(код слияния --строк 20-30)

@mc-black · 28.11.2014, 12:15

Ваш мегакод очень хорошо сжимается, ещё немного времени и я его сожму в крошку и выложу здесь.

@~~Апострофф~~ · 28.11.2014, 12:23

Сообщение от mc-black

Ваш мегакод очень хорошо сжимается

Это мой мегакод

AntonyHopkins, не надо один вопрос обсуждать в разных темах - это наказуемо!

@~~Апострофф~~ · 28.11.2014, 12:42

Visual Basic

a=array("\Багратионовский(новая).xls","\Гвардейский(новая).xls","\Гурьевский(новая).xls") 'продолжите список файлов сами
'aa=array(30,60,61,62)
aa=array(0,30,31,32)
for i=0 to ubound(a)
  with Workbooks.Open (ThisWorkbook.Path & a(i))
    Workbooks("сводная.xls").Activate
    Worksheets("Ввод земли").Range("C7:F7").offset(5*i+i).value=.Worksheets("Ввод земли").Range("C30:F30").offset(aa(i)).value
    Worksheets("Гибель и подкормка").Range("C7:AC7").offset(5*i+i).value=.Worksheets("Гибель и подкормка").Range("C30:AC30").offset(aa(i)).value
    'и т.д.
    .Close
  end with
next i

@AntonyHopkins · 28.11.2014, 12:47 **[ТС]**

Почему-то, смещается но выкидывает данные одного района!

@mc-black · 28.11.2014, 12:56

Попробуйте мой пример. Нужно скопировать (не переименовывать!) лист из книги в ваш свод, а также перенести текст макроса в ваш сводный файл и запустить.

Кликните здесь для просмотра всего текста

Visual Basic

Option Explicit
 
' Основная процедура: сбор данных
Sub GetData()
    Dim sReg() As Variant, i As Long
    
    ' Получить названия районов
    With ThisWorkbook.Worksheets("Районы")
        sReg = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)).Value
    End With
    
    ' Полчить данные районов в цикле
    j = 7
    For i = 1 To UBound(sReg, 1)
        Call GetGataFrom(sReg(i, 1) & "(новая).xls", j) ' Название файла
        j = j + 5
    Next
End Sub
 
' Выпомогательная процедура: копирование данных из листов
Private Sub GetDataFrom(MyName As String, j As Long)
    Dim srcWB As Workbook, sWsh() As Variant, i As Long
    Dim src As Worksheet, dst As Worksheet, j As Long
    
    ' Получить названия листов
    With ThisWorkbook.Worksheets("Районы")
        sWsh = .Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp)).Value
    End With
    
    ' Открыть книгу, сопоставить с ней объектную переменную
    Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\" & MyName)
    
    ' Перечислить имена листов в цикле
    For i = 1 To UBound(sWsh, 1)
        Set src = srcWB.Worksheets(sWsh(i, 1))
        Set dst = ThisWorkbook.Worksheets(sWsh(i, 1))
        
        ' Копируем значения (1)
        dst.Range(dst.Cells(j, 3), dst.Cells(j, sWsh(i, 2))).Value = _
            src.Range(src.Cells(30, 3), src.Cells(30, sWsh(i, 2))).Value
        ' Копируем значения (2)
        dst.Range(dst.Cells(j + 1, 3), dst.Cells(j + 3, sWsh(i, 2))).Value = _
            src.Range(src.Cells(60, 3), src.Cells(62, sWsh(i, 2))).Value
        
        Set src = Nothing
        Set dst = Nothing
    Next
    
    ' Закрыть книгу
    srcWB.Close False
    Set srcWB = Nothing
End Sub

Мне не на чем было тестировать и если я не допустил ошибки, то всё сработает. Если допустил, то надо будет иметь тестовые файлы для проверки или подробную информацию об ошибке.

@AntonyHopkins · 28.11.2014, 13:10 **[ТС]**

Лист скопировать не удается

@AntonyHopkins · 28.11.2014, 13:22 **[ТС]**

Ничего у меня не получается!

@~~Апострофф~~ · 28.11.2014, 13:24

Сообщение от AntonyHopkins

выкидывает данные одного района!

Мой ляп. Надо ещё один цикл вкручивать-

Visual Basic

a=array("\Багратионовский(новая).xls","\Гвардейский(новая).xls","\Гурьевский(новая).xls") 'продолжите список файлов сами
'aa=array(30,60,61,62)
aa=array(0,30,31,32)
for i=0 to ubound(a)
  with Workbooks.Open (ThisWorkbook.Path & a(i))
    for j=0 to 3
      Workbooks("сводная.xls").Activate
      Worksheets("Ввод земли").Range("C7:F7").offset(5*i+j).value=.Worksheets("Ввод земли").Range("C30:F30").offset(aa(j)).value
      Worksheets("Гибель и подкормка").Range("C7:AC7").offset(5*i+j).value=.Worksheets("Гибель и подкормка").Range("C30:AC30").offset(aa(j)).value
      'и т.д.
    next j
    .Close
  end with
next i

@AntonyHopkins · 28.11.2014, 13:34 **[ТС]**

Не перебирает районы

@~~Апострофф~~ Заблокирован
	28.11.2014, 10:54	4
	Сообщение от AntonyHopkins И таких 13 районов А код для всех одинаковый? 0

@mc-black 2785 / 717 / 106 Регистрация: 04.02.2011 Сообщений: 1,443
	28.11.2014, 11:21	7
	Жесть конечно Но попытка засчитана! Спагетти-стайл. Процедуру можно разбить на 2-3 примерно равные, чтобы проверить, работает ли оно? И если работает, то довольствоваться пока этим и улучшать. Но вообще, программирование оно как раз заключается в том, чтобы нагромождения частных моментов заменять изящными сокращениями. В вашем большом коде очень много текстовых данных, которые придется править, если сползет какое-то название так же долго, как вы это сооружали. Смотрите. В сводный файл можно на отдельный лист занести всю эту массу текста, при этом структуриров её в виде какой-то осмысленной таблицы. Лист потом можно скрыть, никто кроме вас его не увидит. И затем написать очень короткий макрос, который пройдется по вспомогательному листу и выполнит инструкции парой-тройкой вложенных циклов и небольшим набором условного ветвления if. 0

shanemac51 Модератор 11960 / 4828 / 779 Регистрация: 07.08.2010 Сообщений: 14,138 Записей в блоге: 4
	28.11.2014, 11:54	11
	этот код в 2 с половиной раза меньше вашего если можно использовать 1 имя вместо двух разница будет более 3 раз если есть закономерность в значении ранге для разных районов ---разница еще больше хотя я видимо изменила структуру рабочего листа(перевела в столбик ) имя книги,все остальные столбики ........... .......... и делала сводную на рабочий лист(код слияния --строк 20-30) 0

@mc-black 2785 / 717 / 106 Регистрация: 04.02.2011 Сообщений: 1,443
	28.11.2014, 12:15	12
	Ваш мегакод очень хорошо сжимается, ещё немного времени и я его сожму в крошку и выложу здесь. 0

@~~Апострофф~~ Заблокирован
	28.11.2014, 12:23	13
	Сообщение от mc-black Ваш мегакод очень хорошо сжимается Это мой мегакод AntonyHopkins, не надо один вопрос обсуждать в разных темах - это наказуемо! 1

@AntonyHopkins 0 / 0 / 0 Регистрация: 13.11.2014 Сообщений: 22
	28.11.2014, 12:47 [ТС]	15
	Почему-то, смещается но выкидывает данные одного района! 0

@AntonyHopkins 0 / 0 / 0 Регистрация: 13.11.2014 Сообщений: 22
	28.11.2014, 13:10 [ТС]	17
	Лист скопировать не удается 0

@AntonyHopkins 0 / 0 / 0 Регистрация: 13.11.2014 Сообщений: 22
	28.11.2014, 13:34 [ТС]	20
	Не перебирает районы 0

Динамическая настройка пути при переносе файла с макросом

Решение