Страницы: 1
RSS
Перебор ячеек диапазона с копированием каждой ячейки и вставкой в разные книги в папке
 
Добрый день. есть задача.
1) Из Excel файла Spisok с помощью цикла осуществляем перебор ячеек диапазона. Диапазон ("B2:B4).
2) Ячейку А2 из файла Spisok копируем и вставляем в файл по наименованию 1 в ячейку A2.
3) Ячейку А3 из файла Spisok копируем и вставляем в файл по наименованию 2 в ячейку А2.
4) Ячейку А4 из файла Spisok копируем и вставляем в файл по наименованию 3 в ячейку А2.
Все это делается с использованием циклов.
Проблема в одновременном переборе циклом диапазона ячеек в файле Spisok для копирования и переборе Excel-файлов 1, 2, 3 для вставки.

Диапазон на самом деле содержит почти 1600 строк. Но его сократил для понимания задачи.

Помогите пожалуйста решить задачу.

Файлы примеров также прикреплены. Есть код (ниже), но не работает.



Sub KopirovanieIVstavkaVRaznyeWorkbook()

Dim MyRange As Range
Dim MyCell As Range
Dim MyFiles As String

Set MyRange = Application.Workbooks(Spisok.xlsm).Worksheets("Sheet1").Range("B2:B4")
       
       For Each MyCell In MyRange
       If MyCell > 0 Then
           MyFiles = Dir("C:\Users\User\Desktop\Papka\*.xlsx")
           Do While MyFiles <> “”
   
       Workbooks.Open "C:\Users\User\Desktop\Papka\" & MyFiles
       ActiveWorkbook.Worksheets(1).Range("A2") = MyCell
       ActiveWorkbook.Close SaveChanges:=True
       MyFiles = Dir
   
       Exit Do
       Loop
       
       Else
       MyCell.Offset(0, 1).Value = "Pusto"
       
   End If
   Next MyCell

End Sub
 
Цитата
Spec написал:  Диапазон ("B2:B4).
Цитата
Spec написал: Ячейку А2
так в итоге что перебираем? ДД.логика есть что и куда?

а строку
Код
 Set MyRange = Workbooks("Spisok.xlsm").Worksheets("Sheet1").Range("B2:B4")
Не бойтесь совершенства. Вам его не достичь.
 
1) Диапазон ("B2:B4) в Workbook Spisok. Это нормализованный список. В Workbook Spisok ячейка А2 занята наименованием. Цены прописаны в диапазоне ("B2:B4)  в Workbook Spisok.

2) Диапазон ("B2:B4) в Workbook Spisok перебираем с помощью цикла. И Каждую ячейку из этого диапазона копируем и вставляем в другую книгу (Эта книга выбирается тоже перебором цикла в папке). Каждая следующая ячейка вставляется в следующую Workbook из папки.

3) В Workbook 1 вставка в ячейку А2.

Короче есть диапазон, и ее нужно раскидать по разным Workbook по одной ячейке. На каждый Workbook из папки будет вставлена одна ячейка из диапазона для разноски.
 
Spec, а при вставке в файл вы проверять не будете туда ли это вставляется?
Не бойтесь совершенства. Вам его не достичь.
 
Mershik, перебираем диапазон в файле Spisok и одновременно перебираем Workbooks в целевой папке. Количество ячеек в диапазоне = кол-ву Workbooks в целевой папке.
 
Доброе время суток
Цитата
Spec написал:
Количество ячеек в диапазоне = кол-ву Workbooks в целевой папке.
И нет никакой разницы в какую книгу какое значение будет вставлено - правильно ли я вас понимаю? Важно просто вставить :)
 
Spec,
Андрей VG, видимо не важно))

https://www.cyberforum.ru/vba/thread360461.html
Код
Sub KopirovanieIVstavkaVRaznyeWorkbook()
Dim s As String, MyFiles As String, i As Long
Application.DisplayAlerts = False
i = 2
MyFiles = "C:\Users\dell\Desktop\papka\"
s = Dir(MyFiles & "*.xls")
Do While s <> ""
    With Workbooks.Open(MyFiles & s)
        .Worksheets(1).Range("A2") = Workbooks("Spisok.xlsm").Worksheets("Sheet1").Range("B" & i)
        .Close SaveChanges:=True
    End With
    i = i + 1
    s = Dir
Loop
Application.DisplayAlerts = True
End Sub
Изменено: Mershik - 05.07.2020 10:54:10
Не бойтесь совершенства. Вам его не достичь.
 
Цитата
Андрей VG написал:  Важно просто вставить
Есть разница куда вставлять. Ячейка с ценой апельсина из диапазона для разноски должна встать в Workbook с апельсином. Только как эту проверку сделать?
 
Spec,
Цитата
Spec написал:
Есть разница куда вставлять.
Цитата
Mershik написал:
вы проверять не будете туда ли это вставляется?
мда...люблю таких ТЗ)
Изменено: Mershik - 05.07.2020 10:58:11
Не бойтесь совершенства. Вам его не достичь.
 
Цитата
Mershik написал:
Spec , а при вставке в файл вы проверять не будете туда ли это вставляется?
Буду проверять, только как это проверить? :D  
 
Spec, всегда в открываемы хайлах в первой ячейке наименование типа "Фрукт 1, в руб." ???\
раз сделал пусть будет для этого варианта
Код
Sub KopirovanieIVstavkaVRaznyeWorkbook()
Dim s As String, MyFiles As String, MyVal As Range
Application.DisplayAlerts = False
MyFiles = "C:\Users\dell\Desktop\papka\"
s = Dir(MyFiles & "*.xls")
Do While s <> ""
    With Workbooks.Open(MyFiles & s)
    x = Left(.Worksheets(1).Range("A1"), InStr(1, .Worksheets(1).Range("A1"), ",") - 1)
        Set MyVal = Workbooks("Spisok.xlsm").Worksheets("Sheet1").Columns(1).Find(x)
        If Not MyVal Is Nothing Then
        .Worksheets(1).Range("A2") = MyVal.Offset(0, 1)
        .Close SaveChanges:=True
        End If
    End With
    s = Dir
Loop
Application.DisplayAlerts = True
End Sub
Изменено: Mershik - 05.07.2020 11:10:58
Не бойтесь совершенства. Вам его не достичь.
 
Цитата
Spec написал:
встать в Workbook с апельсином
Как это можно узнать, посредством email запроса вышестоящему руководителю?!
 
Диапазон В2:В4 расположен статично. Возможно как то можно организовать Workbook по порядку, присвоив им в названии цифры от 1 до 1600 в начале названия файла.

Цитата
Как это можно узнать, посредством email запроса вышестоящему руководителю?!
Индексация В2:В4 она ведь уже сверху вниз, т.е. от 1 до 1600

Цитата
Mershik написал:  Spec , всегда в открываемы хайлах в первой ячейке наименование типа "Фрукт 1, в руб." ???
Нет. Апельсин китай или turkey-107:апельсин может быть. В названии Workbook слово апельсин будет.
 
Цитата
Spec написал:
присвоив им в названии цифры от 1 до 1600
Может сделать всё проще - в ячейки C2:C4 первого листа книги Spisok.xlsm записать названия файлов? И тогда порно с двумя циклами и нечётким поиском не потребуется использовать.
Изменено: Андрей VG - 05.07.2020 11:17:24
 
Круто, а как это будет в VBA коде? Правда ручной работы предстоит, но это лучше чем  все копировать/вставить ручками :D  
 
Цитата
Spec написал: Правда ручной работы предстоит
https://www.planetaexcel.ru/techniques/12/45/
а вы пробовали хоть один макрос предложенным мной?
Не бойтесь совершенства. Вам его не достичь.
 
Конечно, но я удалил в Excel - файле 1, 2, 3, значение с ячейки А2. И запустил Ваш макрос. Ни цена 500, 600 или 700 руб. не появились. Я даже Ваш код VBA занес в Visual Studio Code для подсветки и понять его. Сижу разбираю. Но Ваш код не работает. Ошибку Runtime не выдает. но и не копирует куда надо.
 
Spec, а у меня все работает согласно вашим файлам приложенным )ну удачи)
Не бойтесь совершенства. Вам его не достичь.
 
У Вас какой Office 2013 64x? И excel файлы должны быстрренько сами открыться и закрыться?
 
Spec, код следует оформлять соответствующим тегом. Ищите такую кнопку (см. скрин) и исправьте своё сообщение.
 
Spec, 2019 64, да открылись закрылись файлы. На гифке убрал закрытие и сохранение что бы показать что все вставляется
Изменено: Mershik - 05.07.2020 12:05:47
Не бойтесь совершенства. Вам его не достичь.
 
Вы крутой человек, работает 2 код. Ставлю 10 баллов из 10 баллов.
 
Spec, а Вам ставлю 2 балла из 12 - цитировать не умеете. Цитата - не бестолковая копия сообщения!

Замечание модератора игнорируете (соощение №20)
Страницы: 1
Наверх