Макрос для копирования определённых данных с разных книг

@Jamaldin · Регистрация: 21.04.2021

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

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

Пример Лист1- Наташа, Лист2- Саша, Лист3 -Олег.
А1-Дата заказа B1-Сумма заказа С1-Сумма расчета D1-Остаток долга

За ориентир можно брать ячейку правее от ячейки с текстом "Предварительная стоимость"

@КостяФедореев · 27.04.2021, 16:06

Jamaldin, попробуйте этот код, не должен удалять старые данные.

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

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
Sub www()
    Dim avFiles
    Dim ws          As Worksheet
    Dim mas         As Variant
    Dim xWs         As Worksheet
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.DisplayAlerts = True
    WorkWB = ThisWorkbook.Name
    avFiles = Application.GetOpenFilename _
            ("Excel files(*.xls*),*.xls*", 1, "Выбрать Excel файлы", , True)
    If VarType(avFiles) = vbBoolean Then
        Exit Sub
    End If
    Set dict = CreateObject("Scripting.Dictionary")
    For Each x In avFiles
        Workbooks.Open x
        For Each ws In Application.Worksheets
            ws.Activate
            Set rF = ActiveSheet.UsedRange.Find("Предварительная стоимость", , _
                    xlValues, xlWhole, , xlPrevious)
            lRow = rF.Row
            With dict
                t = Left(Cells(1, 2).Value, Len(Cells(1, 2).Value) - 5)
                If Cells(1, 1).Value = "" And Cells(lRow, 5).Value = "" Then GoTo NextWS
                trtr = Cells(1, 1).Value
                tt = Cells(1, 1).Value & "|" & Cells(lRow, 5).Value
                If Not .exists(t) Then
                    .Item(t) = tt
                Else
                    .Item(t) = .Item(t) & ";" & Cells(1, 1).Value & "|" & Cells(lRow, 5).Value
                End If
            End With
        Next
NextWS:
        ActiveWindow.Close False
    Next
    Dim ttt         As String
    For Each varKey In dict.keys
        varItem = dict.Item(varKey)
        ttt = varKey
        If Not Sh_Exist(ActiveWorkbook, ttt) Then
            ActiveWorkbook.Sheets.Add(, ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)).Name = ttt
            Cells(1, 1) = "Дата заказа"
            Cells(1, 2) = "Сумма Заказа"
            Cells(1, 3) = "Расчет"
            Cells(1, 4) = "Долг"
        Else
            Worksheets(ttt).Activate
        End If
        Dim FL      As Boolean
        Dim e1      As String
        Dim e2      As String
        For i = 0 To UBound(Split(varItem, ";"))
        FL = False
            lr0 = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
            dg = Split(varItem, ";")(i)
            For j = 2 To lr0
                If CStr(Split(dg, "|")(0)) = CStr(Cells(j, 1)) Then FL = True
            Next
            If FL = False Then
                Cells(lr0 + 1, 1) = Split(dg, "|")(0)
                Cells(lr0 + 1, 2) = Split(dg, "|")(1)
            End If
        Next
    Next
    Application.ScreenUpdating = True
End Sub
Function Sh_Exist(wb As Workbook, sName As String) As Boolean
    Dim wsSh        As Worksheet
    On Error Resume Next
    Set wsSh = wb.Sheets(sName)
    Sh_Exist = Not wsSh Is Nothing
End Function

@Jamaldin · 30.04.2021, 07:02 **[ТС]**

Сообщение от КостяФедореев

попробуйте этот код, не должен удалять старые данные.

Этот Код работает, как нужно. Спасибо большое за ваш труд

КостяФедореев,Но тут появилась загвоздка. В общем картина такая. У нас интернет магазин, заказы падают на сайт, оттуда мы экспортируем в эксель. Это те самые файлы которые я вам скидывал с датой в ячейке "А1" и "Предварительной стоимостью" (файл Пример2).
Сейчас до меня допёрло, что обрабатывать и брать данные нужно во все не с этого файла. Это заказ клиента, а реальная накладная по факту уже сборки заказа отличается от заказа клиента. Так как у нас оптовые продажи и иногда нет нужного количества, иногда товар уже купили перед этим клиентом, т.е. товар закончился и тп. в общем по разным причинам. Заказы мы прогоняем через 1С и в итоге фактическая накладная выходит, как стандартная "расходная накладная". Ниже прикрепил пример.

Скажите пожалуйста, возможно ли подредактировать тот код под эти таблицы?
В этой таблице запрос на ячейки будет по другому.
А1 - Берется инфа с R2C2, В1 - R6C12, C1 - Ячейка правее от ячейки "Итого:", D1 - так же сумма расчета, E1 - долг (если возможно сразу кодом (E1=С1-D1 и т.д. E2,E3)
Получается:
А1 - Расходная накладная № 00000000824 от April 29, 2021, B1- Ж. Кельджанова Актау, С1- 585000, D1 - вручную, E1 - долг

КостяФедореев, Ответьте пожалуйста возьмётесь ли?

@Jamaldin · 30.04.2021, 07:20 **[ТС]**

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

В этой таблице запрос на ячейки будет по другому.
А1 - Берется инфа с R2C2, В1 - R6C12, C1 - Ячейка правее от ячейки "Итого:", D1 - так же сумма расчета, E1 - долг (если возможно сразу кодом (E1=С1-D1 и т.д. E2,E3)
Получается:
А1 - Расходная накладная № 00000000824 от April 29, 2021, B1- Ж. Кельджанова Актау, С1- 585000, D1 - вручную, E1 - долг

В этом случае получается нет листов как в "Примере2", тут одна книга - один заказ (любого клиента) И их нужно объединить так же в листы в книге "Сводка" опираясь на Имя клиента с ячейки R2C2

@КостяФедореев · 30.04.2021, 10:38

Jamaldin, попробуйте

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

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
Sub www()
    Dim avFiles
    Dim ws          As Worksheet
    Dim mas         As Variant
    Dim xWs         As Worksheet
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.DisplayAlerts = True
    WorkWB = ThisWorkbook.Name
    avFiles = Application.GetOpenFilename _
            ("Excel files(*.xls*),*.xls*", 1, "Выбрать Excel файлы", , True)
    If VarType(avFiles) = vbBoolean Then
        Exit Sub
    End If
    Set dict = CreateObject("Scripting.Dictionary")
    For Each x In avFiles
        Workbooks.Open x
        For Each ws In Application.Worksheets
            ws.Activate
            Set rF = ActiveSheet.UsedRange.Find("Итого:", , _
                    xlValues, xlWhole, , xlPrevious)
            lRow = rF.Row
            lCol = rF.Column
            With dict
                t = Cells(6, 12).Value
                tt = Cells(2, 2).Value & "|" & t & "|" & Cells(lRow, lCol + 1).Value
                If Not .exists(t) Then
                    .Item(t) = tt
                Else
                    .Item(t) = .Item(t) & ";" & Cells(1, 1).Value & "|" & Cells(lRow, 5).Value
                End If
            End With
        Next
NextWS:
        ActiveWindow.Close False
    Next
    Dim ttt         As String
    For Each varKey In dict.keys
        varItem = dict.Item(varKey)
        ttt = varKey
        If Not Sh_Exist(ActiveWorkbook, ttt) Then
            ActiveWorkbook.Sheets.Add(, ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)).Name = ttt
            Cells(1, 1) = "Дата заказа"
            Cells(1, 2) = "ФИО"
            Cells(1, 3) = "Сумма Заказа"
            Cells(1, 4) = "Расчет"
            Cells(1, 5) = "Долг"
        Else
            Worksheets(ttt).Activate
        End If
        Dim FL      As Boolean
        Dim e1      As String
        Dim e2      As String
        For i = 0 To UBound(Split(varItem, ";"))
            FL = False
            lr0 = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
            dg = Split(varItem, ";")(i)
            For j = 2 To lr0
                If CStr(Split(dg, "|")(0)) = CStr(Cells(j, 1)) Then FL = True
            Next
            If FL = False Then
                Cells(lr0 + 1, 1) = Split(dg, "|")(0)
                Cells(lr0 + 1, 2) = Split(dg, "|")(1)
                Cells(lr0 + 1, 3) = Split(dg, "|")(2)
            End If
        Next
    Next
    Application.ScreenUpdating = True
End Sub
Function Sh_Exist(wb As Workbook, sName As String) As Boolean
    Dim wsSh        As Worksheet
    On Error Resume Next
    Set wsSh = wb.Sheets(sName)
    Sh_Exist = Not wsSh Is Nothing
End Function

@Jamaldin · 30.04.2021, 14:35 **[ТС]**

Сообщение от КостяФедореев

попробуйте

Все работает как надо! Спасибо! Не сочтите за наглость, но есть еще один, такой маааленький вопрос

В столбец с Названием долг, можно програмно вставить формулу? чтоб не писать ее на каждом листе и тянуть в низ? (т.е. E1=С1-D1, E2=С2-D2 и т.д.)
И где-нибудь с краю в ячейку R2C7 вставить сумму долга, т.е. столбца "Е" (Желательно в виде "Общий Долг - xxxxxx")

@КостяФедореев · 30.04.2021, 15:14

Jamaldin,

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

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
Sub www()
    Dim avFiles
    Dim ws          As Worksheet
    Dim mas         As Variant
    Dim xWs         As Worksheet
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.DisplayAlerts = True
    WorkWB = ThisWorkbook.Name
    avFiles = Application.GetOpenFilename _
            ("Excel files(*.xls*),*.xls*", 1, "Выбрать Excel файлы", , True)
    If VarType(avFiles) = vbBoolean Then
        Exit Sub
    End If
    Set dict = CreateObject("Scripting.Dictionary")
    For Each x In avFiles
        Workbooks.Open x
        For Each ws In Application.Worksheets
            ws.Activate
            Set rF = ActiveSheet.UsedRange.Find("Итого:", , _
                    xlValues, xlWhole, , xlPrevious)
            lRow = rF.Row
            lCol = rF.Column
            With dict
                t = Cells(6, 12).Value
                tt = Cells(2, 2).Value & "|" & t & "|" & Cells(lRow, lCol + 1).Value
                If Not .exists(t) Then
                    .Item(t) = tt
                Else
                    .Item(t) = .Item(t) & ";" & tt
                End If
            End With
        Next
NextWS:
        ActiveWindow.Close False
    Next
    Dim ttt         As String
    For Each varKey In dict.keys
        varItem = dict.Item(varKey)
        ttt = varKey
        If Not Sh_Exist(ActiveWorkbook, ttt) Then
            ActiveWorkbook.Sheets.Add(, ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)).Name = ttt
            Cells(1, 1) = "Дата заказа"
            Cells(1, 2) = "ФИО"
            Cells(1, 3) = "Сумма Заказа"
            Cells(1, 4) = "Расчет"
            Cells(1, 5) = "Долг"
            Cells(1, 6) = "Общий долг"
        Else
            Worksheets(ttt).Activate
        End If
        Dim FL      As Boolean
        Dim e1      As String
        Dim e2      As String
        For i = 0 To UBound(Split(varItem, ";"))
            FL = False
            lr0 = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
            dg = Split(varItem, ";")(i)
            For j = 2 To lr0
                If CStr(Split(dg, "|")(0)) = CStr(Cells(j, 1)) Then FL = True
            Next
            If FL = False Then
                Cells(lr0 + 1, 1) = Split(dg, "|")(0)
                Cells(lr0 + 1, 2) = Split(dg, "|")(1)
                Cells(lr0 + 1, 3) = Split(dg, "|")(2)
                Cells(lr0 + 1, 5).FormulaLocal = "=C" & lr0 + 1 & "-D" & lr0 + 1
            End If
        Next
    Next
    lr1 = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
    Cells(2, 6).FormulaLocal = "=СУММ(E2:E" & lr1 & ")"
    Application.ScreenUpdating = True
End Sub
Function Sh_Exist(wb As Workbook, sName As String) As Boolean
    Dim wsSh        As Worksheet
    On Error Resume Next
    Set wsSh = wb.Sheets(sName)
    Sh_Exist = Not wsSh Is Nothing
End Function

@Jamaldin · 30.04.2021, 15:32 **[ТС]**

КостяФедореев, Спасибо вам огромнейшее))) Капец как выручили!

Новые блоги и статьи Все статьи Все блоги /
GitHub Copilot в JetBrains: модель по умолчанию, Fix и контроль MCP and_y87 12.10.2026 10 октября 2026 года GitHub обновил Copilot для JetBrains: добавил настройки стартовой модели, исправления из диагностики и управление автозапуском MCP. Поддержка IDE 2025. 1 прекращена — требуется. . .	День 5 из 28: Codex подсказывает следующий запрос and_y87 12.10.2026 9 октября 2026 года OpenAI запустила бету Composer predictions — подсказок следующего сообщения в текущем диалоге Codex. Это помощь с формулировкой запроса, а не автоматическое продолжение задачи. . . .	Запустил конкурс "тем и промптов для текстовых квестов созданных почти чисто ИИ" Adler 06.10.2026 Всем привет! За последние три-четыре дня я создал более 16 текстовых квестовых игр используя преимущественно по одному запросу к ИИ на игру. Мне так понравилось смотреть все ветки/ сцены во всех. . .	ИИ не может найти нужный язык в списке Supersumestria 05.10.2026 Я ему даю вот такое изображение и прошу найти и подчеркнуть немецкий язык. Возвращает он вот это: https:/ / i. **********/ vqBWLe2. png Нужную строчку в 3й колонке просто выдумал. . Это. . .
Новая последняя моя музыка в SUNO zorxor 05.10.2026 Здравствуйте, дорогие мои друзья! С большой радостью я хотел бы представить вам свою новую последнею музыку, которую сгенерировала мне по моей просьбе нейросеть SUNO. С уважением, zorxor. Это. . .	Программный домашний кинотеатр russiannick 27.09.2026 Сподобился на программный домашний кинотеатр. В качестве ЯВУ по традиции выбрал js. В помощники взял Яндекс-Алису. Было создано три зала на разные интересы. исторические и ретро сериал Хичкок. . .	Беседа с ИИ о программистах, недопускающих к созданию и правке кода генеративные ИИ и причины этого zorxor 21.09.2026 Раньше я радовался или получал некоторые эмоции, пусть небольшие, но всё же, от самого процесса написания кода, рекомпиляции и запуска, видя постепенное развитие программы и прочее. А теперь лень. . .	Мобильное приложение ColorStep pavlinmavlin 17.09.2026 Реализовал приложение Красный, Зеленый, Синий в Unity3d + c#. Название изменил на ColorStep. Приложение прошло модерацию и теперь доступно для скачивания. Делал его сам, шаг за шагом — и вот,. . .

Макрос для копирования определённых данных с разных книг

Решение

Решение

Решение

@Jamaldin 1 / 1 / 0 Регистрация: 21.04.2021 Сообщений: 18
	30.04.2021, 15:32 [ТС]
	КостяФедореев, Спасибо вам огромнейшее))) Капец как выручили! 0