Умный перенос данных по ячейкам в ячейки другого листа

[Toffifee]

Дыры эти я закрою, потому что пока в новом отчете по этим городам прибыли нет, их в отчет и не занесли.
Ну я не знаю, думаю удобнее будет просто эту таблицу соответствий в отдельном файле хранить, чтоб открыл, исправил, сохранил и дальше работает. А если она будет в той огромной книге, где 49 листов, откуда копируются 3 листа, это её менять надо будет постоянно, и многим сотрудникам её менять на компах у себя. Это муторно и всех напрягать. А дополнительные города постоянно открываются.
Так можно сделать? Как сделать?

[Hugo121]

Положить таблицу в общий файл на сервере, прописать в код постоянный путь к этому файлу, брать таблицу с помощью GetObject, вот например пример:

Sub ПримерИспользования_GetFileName()
ИмяФайла = GetFileName("Заголовок окна", ThisWorkbook.Path) ' запрашиваем имя файла
' ===================== другие варианты вызова функции =====================
' текстовые файлы, стартовая папка не указана
' ИмяФайла = GetFileName("Выберите текстовый файл", , "Текстовые файлы (*.txt),")
' файлы любого типа из папки "C:\Windows"
' ИмяФайла = GetFileName(, "C:\Windows", "")
' ==========================================================================

If ИмяФайла = "" Then Exit Sub ' выход, если пользователь отказался от выбора файла
'MsgBox "Выбран файл: " & ИмяФайла, vbInformation
With GetObject(ИмяФайла)
ThisWorkbook.Sheets(1).[a1] = .Sheets(1).[a1]
.Close 0
End With
End Sub

Можно использовать, переделав - взяли таблицу, загнали в массив, файл можно закрыть.
Примерно так (в работе не проверял):

With GetObject(ИмяФайла)
    With .[equivalent]
        a = .Range("A1:B" & .Range("B" & .Rows.Count).End(xlUp).Row).Value
    End With
.Close 0
End With

[Toffifee]

А вот в этот код:

Sub Создать_Ежедневный_Отчет()
'
' Создать_Ежедневный_Отчет Макрос
'
Dim wb As Workbook
Dim nsheet As Worksheet

Sheets(Array("КАССА ИТОГ", "1С И ПРОЧЕЕ", "АНАЛИЗ ПРИБЫЛИ")).Copy
Set wb = ActiveWorkbook ' ссылка на новую созданную книгу

Dim itogWB As Workbook
For Each itogWB In Workbooks ' перебирает все открытые книги
If InStr(itogWB.Name, "С") Then ' находим открытую книгу с названием
itogWB.Sheets("Бюджет").Copy Before:=wb.Worksheets(1) 'при совпадении копирует лист и выходим из цикла перебора
With wb.Worksheets(1)
.Columns("C:AH").EntireColumn.Hidde n = True ' скрываем столбцы с C:AH
.Columns("AP:AY").EntireColumn.Hidd en = True ' скрываем столбцы с AP:AY
End With
Exit For
End If
Next

wb.SaveAs Filename:="C:\Documents and Settings\a_safarova\Рабочий стол\ДОКУМЕНТЫ (АЛЬФИЯ)\ОТЧЕТЫ ежемесячные\БДР\Ежедневный отчет.xls", FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False

End Sub

Можно ли добавить вышепредставленный код где: Sub ПримерИспользования_GetFileName()
или его отдельным модулем вставлять?

[Hugo121]

Добавить то можно, но Вам точно нужен диалог выбора файла?
И я там саму функцию не привёл, т.к. речь шла только о GetObject, целиком оно так выглядит:

Sub ПримерИспользования_GetFileName()
ИмяФайла = GetFileName("Заголовок окна", ThisWorkbook.Path) ' запрашиваем имя файла
' ===================== другие варианты вызова функции =====================
' текстовые файлы, стартовая папка не указана
' ИмяФайла = GetFileName("Выберите текстовый файл", , "Текстовые файлы (*.txt),")
' файлы любого типа из папки "C:\Windows"
' ИмяФайла = GetFileName(, "C:\Windows", "")
' ==========================================================================

If ИмяФайла = "" Then Exit Sub ' выход, если пользователь отказался от выбора файла
'MsgBox "Выбран файл: " & ИмяФайла, vbInformation
With GetObject(ИмяФайла)
ThisWorkbook.Sheets(1).[a1] = .Sheets(1).[a1]
.Close 0
End With
End Sub

Function GetFileName(Optional ByVal Title As String = "Выберите файл для обработки", _
Optional ByVal InitialPath, _
Optional ByVal MyFilter As String = "Книги Excel (*.xls*),") As String
' функция выводит диалоговое окно выбора папки с заголовком Title,
' начиная обзор диска с папки InitialPath
' возвращает полный путь к выбранной папке, или пустую строку в случае отказа от выбора
If Not IsMissing(InitialPath) Then
On Error Resume Next: ChDrive Left(InitialPath, 1)
ChDir InitialPath ' выбираем стартовую папку
End If
res = Application.GetOpenFilename(MyFilter, , Title, "Открыть") ' вывод диалогового окна
GetFileName = IIf(VarType(res) = vbBoolean, "", res) ' пустая строка при отказе от выбора
End Function

[Toffifee]

Ну я себе вот так представляю это:
1. Запустили макрос, нажатием на кнопку, скорировались 4 листа (3 из той книги с которой запускается макрос и один лист из другой открытой книги);
2. Вот они скопировались, теперь он обращается по назначенному пути к файлу, где соответствия городов.
3. Теперь он работает как приложенный до этого файл. То есть берет значения и подставляет их по городам в таблицу.

Это наверное всё в одном коде дожно быть, мы ведь если макрос Sub Создать_Ежедневный_Отчет() запускаем, всё должно последовательно проделаться...

[Hugo121]

Да в общем уже выше написал почти правильно
Если список городов на первом листе файла C:\temp\Toffifee\2\Spisok_gorodov.x ls, то берём его так:

With GetObject("C:\temp\Toffifee\2\Spisok_gorodov.xls")
    With .Sheets(1)
        a = .Range("A1:B" & .Range("B" & .Rows.Count).End(xlUp).Row).Value
    End With
.Close 0
End With

Правда не проверял, как это будет работать с сетевым путём.
Типа

\\I777\user\spisok_gorodov.xls

P.S. Уже проверил - работает.

Итого:

Option Explicit

Sub Perenos()
Dim a(), oDict As Object, i&, x As Range, iFirstAddress$, ii&
Application.ScreenUpdating = False

With GetObject("C:\temp\Toffifee\2\Spisok_gorodov.xls")
    With .Sheets(1)
        a = .Range("A1:B" & .Range("B" & .Rows.Count).End(xlUp).Row).Value
    End With
.Close 0
End With

    Set oDict = CreateObject("Scripting.Dictionary")
    oDict.CompareMode = vbTextCompare

    For i = 1 To UBound(a): oDict.Item(a(i, 1)) = a(i, 2): Next

With [Лист1]
    a = .Range("B6:AM" & .Range("AM" & .Rows.Count).End(xlUp).Row - 1).Value ' диапазон столбцов с цифрами во вкладке "Бюджет"
End With


With [Лист47] ' переход на лист "1С и прочее"
For i = 1 To UBound(a)
If oDict.Exists(a(i, 1)) Then
Set x = .Rows(7).Find(oDict.Item(a(i, 1)), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)

If Not x Is Nothing Then 'если нашли

    iFirstAddress = x.Address 'запоминаем адрес
            
    Do 'цикл
        Set x = .Rows(7).FindNext(x) 'ищем дальше
        If x.Offset(1, 0) = "ЦМ" Then
'        'тут делаем дело с найденным, копируем значения
'        'из массива на лист в найденные столбцы
       For ii = 13 To 17: .Cells(ii, x.Column).Value = a(i, ii + 21): Next
       Exit Do 'выход, т.к. уже нашли, что искали
'        Debug.Print x.Address ' для проверки
        End If
    'ищем дальше, пока не вернёмся к первому найденному
    Loop While Not x Is Nothing And x.Address <> iFirstAddress
    
End If

End If
Next
End With

Erase a 'освобождаем память
Application.ScreenUpdating = True
End Sub

[Toffifee]

Спасибо.... Я теперь только не понимаю как вышепредставленный код соединить вот с этим кодом:

Sub Создать_Ежедневный_Отчет()
'
' Создать_Ежедневный_Отчет Макрос
'
Dim wb As Workbook
Dim nsheet As Worksheet

Sheets(Array("КАССА ИТОГ", "1С И ПРОЧЕЕ", "АНАЛИЗ ПРИБЫЛИ")).Copy
Set wb = ActiveWorkbook ' ссылка на новую созданную книгу

Dim itogWB As Workbook
For Each itogWB In Workbooks ' перебирает все открытые книги
If InStr(itogWB.Name, "С") Then ' находим открытую книгу с названием
itogWB.Sheets("Бюджет").Copy Before:=wb.Worksheets(1) 'при совпадении копирует лист и выходим из цикла перебора
With wb.Worksheets(1)
.Columns("C:AH").EntireColumn.Hidde n = True ' скрываем столбцы с C:AH
.Columns("AP:AY").EntireColumn.Hidd en = True ' скрываем столбцы с AP:AY
End With
Exit For
End If
Next

wb.SaveAs Filename:="C:\Temp\Ежедневный отчет.xls", FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False

End Sub


помогите пожалуйста....

[Hugo121]

Я тоже не очень понимаю, что Вы хотите достичь...
Если сперва заполнить данные, потом скопировать листы, то просто запускайте их последовательно.
Можно для этого третий код написать:

Sub Rabota()
Perenos
Создать_Ежедневный_Отчет
End Sub

Его и запускать.

[Toffifee]

Даа, можно и так. Но у меня не работает. И я поняла причину.
В этом месте кода:

With [Лист1]
a = .Range("B6:AM" & .Range("AM" & .Rows.Count).End(xlUp).Row - 1).Value ' диапазон столбцов с цифрами во вкладке "Бюджет"
End With

With [Лист47] ' переход на лист "1С и прочее"
For i = 1 To UBound(a)
If oDict.Exists(a(i, 1)) Then
Set x = .Rows(7).Find(oDict.Item(a(i, 1)), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)

Вот где лист 1, в коде подразумевается что данный лист есть в книге. А этот лист то из другой книги, и когда мы листы копировали, мы находили открытую книгу которая начинается на определенную букву и оттуда тянули лист. Получается здесь надо не с первого листа этой книги брать цифры, а с первого листа открытой книги, вот кусок кода из переноса листов:

im itogWB As Workbook
For Each itogWB In Workbooks ' перебирает все открытые книги
If InStr(itogWB.Name, "С") Then ' находим открытую книгу с названием
itogWB.Sheets("Бюджет").Copy Before:=wb.Worksheets(1) 'при совпадении копирует лист и выходим из цикла перебора

[Hugo121]

Да, там нужно по месту отследить имена листов.
[Лист1] - это CodeName листа, но оно тоже может измениться, если в эту книгу будет скопирован лист с таким же именем, или изменится имя этого скопированного листа.
Как вариант - сперва дать нужным листам оригинальные имена (вручную или кодом), тогда после копирования проблем с именами быть не должно.