Экспорт данных из одной книги в другую

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Экспорт данных из одной книги в другую (Макросы/Sub)

Egyptian

Дата: Пятница, 21.02.2025, 16:04 | Сообщение № 1

Группа: Проверенные

Ранг: Ветеран

Сообщений: 530

Репутация: 193 ±

Замечаний: 0% ±

Excel 2013/2016

Доброго всем дня. Сразу оговорюсь, файл рабочий, но вся важная информация из него удалена. Размер большой, но сама операция касается только двух книг Grids и Export. В VBA я не разбираюсь (лишь на самом начальном уровне), поэтому прошу помощи.

Итак, макрос в файле (Module1 - кнопка Save в книге Grids) экспортирует информацию из книги Grids в книгу Export, данные не перезаписываются, а каждый раз добавляются.
Суть в том, что когда число записей в книге Export переваливает за 800 макрос начинает сбоить. На вид макрос простой и понятный, но возможно в этом и есть беда.
Можно ли как-нибудь его сократить / оптимизировать?

Код:
[vba]

Код

Sub Submit()

Dim Last_Export_Raw As Integer
Dim Last_Attribute As Long
Dim Last_Chapter As Long

Set acitivitySlicer = ThisWorkbook.SlicerCaches("Slicer_Activity1")
Set guidelineSlicer = ThisWorkbook.SlicerCaches("Slicer_Guideline1")

Last_Export_Raw = Application.CountA(ThisWorkbook.Sheets("Export").Range("A:A")) + 1

Last_Attribute = Application.CountA(ThisWorkbook.Sheets("Grids").Range("A18:A100"))

'Activity
ThisWorkbook.Sheets("Export").Range("A" & Last_Export_Raw).Value = acitivitySlicer.VisibleSlicerItems(1).Caption

'Guideline

ThisWorkbook.Sheets("Export").Range("B" & Last_Export_Raw).Value = guidelineSlicer.VisibleSlicerItems(1).Caption

'Mean of communication

ThisWorkbook.Sheets("Export").Range("C" & Last_Export_Raw).Value = ThisWorkbook.Sheets("Grids").Range("B8")

'Case record ID

ThisWorkbook.Sheets("Export").Range("D" & Last_Export_Raw).Value = ThisWorkbook.Sheets("Grids").Range("B3")

'Market

ThisWorkbook.Sheets("Export").Range("E" & Last_Export_Raw).Value = ThisWorkbook.Sheets("Grids").Range("B4")

'Market_CSC

ThisWorkbook.Sheets("Export").Range("F" & Last_Export_Raw).Value = ThisWorkbook.Sheets("Grids").Range("B4")

'Evaluation date

ThisWorkbook.Sheets("Export").Range("G" & Last_Export_Raw).Value = ThisWorkbook.Sheets("Grids").Range("B5")

'Auditee ID

ThisWorkbook.Sheets("Export").Range("H" & Last_Export_Raw).Value = ThisWorkbook.Sheets("Grids").Range("B6")

'#TAG

ThisWorkbook.Sheets("Export").Range("I" & Last_Export_Raw).Value = ThisWorkbook.Sheets("Grids").Range("B11")

'Auditor ID

ThisWorkbook.Sheets("Export").Range("J" & Last_Export_Raw).Value = "GE-GE-1000659474"

'Sample Type

ThisWorkbook.Sheets("Export").Range("K" & Last_Export_Raw).Value = ThisWorkbook.Sheets("Grids").Range("B9")

'Assessment Condition

ThisWorkbook.Sheets("Export").Range("L" & Last_Export_Raw).Value = ThisWorkbook.Sheets("Grids").Range("B10")

'Topic-Program

ThisWorkbook.Sheets("Export").Range("M" & Last_Export_Raw).Value = ThisWorkbook.Sheets("Grids").Range("B12")

'Subject

ThisWorkbook.Sheets("Export").Range("N" & Last_Export_Raw).Value = ThisWorkbook.Sheets("Grids").Range("B13")

'Empty cell

ThisWorkbook.Sheets("Export").Range("O" & Last_Export_Raw).Value = ""

'Pot. Solution?

ThisWorkbook.Sheets("Export").Range("P" & Last_Export_Raw).Value = ThisWorkbook.Sheets("Grids").Range("C4")

'Process to solve?

ThisWorkbook.Sheets("Export").Range("Q" & Last_Export_Raw).Value = ThisWorkbook.Sheets("Grids").Range("C6")

'QM Final Score

ThisWorkbook.Sheets("Export").Range("R" & Last_Export_Raw).Value = ThisWorkbook.Sheets("Grids").Range("N55")

'Task Category

ThisWorkbook.Sheets("Export").Range("S" & Last_Export_Raw).Value = ""

'Task Subject

ThisWorkbook.Sheets("Export").Range("T" & Last_Export_Raw).Value = ""

'MID

ThisWorkbook.Sheets("Export").Range("U" & Last_Export_Raw).Value = ""

'TID

ThisWorkbook.Sheets("Export").Range("V" & Last_Export_Raw).Value = ""

'Wrap up

ThisWorkbook.Sheets("Export").Range("W" & Last_Export_Raw).Value = ""

'QM_Chapter

ThisWorkbook.Sheets("Grids").Range("A18:A" & Last_Attribute + 17).Copy
ThisWorkbook.Sheets("Export").Range("X" & Last_Export_Raw).PasteSpecial xlPasteValues

'QM_Chapter_Score

ThisWorkbook.Sheets("Grids").Range("O18:O" & Last_Attribute + 17).Copy
ThisWorkbook.Sheets("Export").Range("Y" & Last_Export_Raw).PasteSpecial xlPasteValues

'QM_Dimension

ThisWorkbook.Sheets("Grids").Range("B18:B" & Last_Attribute + 17).Copy
ThisWorkbook.Sheets("Export").Range("Z" & Last_Export_Raw).PasteSpecial xlPasteValues

'QM_Dimension_Assessment

ThisWorkbook.Sheets("Grids").Range("L18:L" & Last_Attribute + 17).Copy
ThisWorkbook.Sheets("Export").Range("AA" & Last_Export_Raw).PasteSpecial xlPasteValues

'Comment

ThisWorkbook.Sheets("Grids").Range("M18:M" & Last_Attribute + 17).Copy
ThisWorkbook.Sheets("Export").Range("AB" & Last_Export_Raw).PasteSpecial xlPasteValues

'Drag General Information
Last_Chapter = Application.CountA(ThisWorkbook.Sheets("Export").Range("X:X"))

ThisWorkbook.Sheets("Export").Range("A" & Last_Export_Raw & ":" & "W" & Last_Export_Raw).Copy
ThisWorkbook.Sheets("Export").Range("A" & Last_Export_Raw & ":" & "W" & Last_Chapter).PasteSpecial xlPasteValues

'Selection.AutoFill Destination:=Range("AY2:AY1662")

End Sub

[/vba]

Код

[/vba]Egyptian

К сообщению приложен файл: quality_audit_grids_v2_2_7_feb.rar (434.9 Kb)

Сообщение отредактировал Egyptian - Пятница, 21.02.2025, 16:19

Ответить

СообщениеДоброго всем дня. Сразу оговорюсь, файл рабочий, но вся важная информация из него удалена. Размер большой, но сама операция касается только двух книг Grids и Export. В VBA я не разбираюсь (лишь на самом начальном уровне), поэтому прошу помощи.

Итак, макрос в файле (Module1 - кнопка Save в книге Grids) экспортирует информацию из книги Grids в книгу Export, данные не перезаписываются, а каждый раз добавляются.
Суть в том, что когда число записей в книге Export переваливает за 800 макрос начинает сбоить. На вид макрос простой и понятный, но возможно в этом и есть беда.
Можно ли как-нибудь его сократить / оптимизировать?

Код:
[vba]

Код

[/vba]

Автор - Egyptian
Дата добавления - 21.02.2025 в 16:04

MikeVol

Дата: Пятница, 21.02.2025, 16:39 | Сообщение № 2

Группа: Проверенные

Ранг: Обитатель

Сообщений: 398

Репутация: 88 ±

Замечаний: 0% ±

MSO LTSC 2021 EN

Egyptian, Доброго времени суток. У вас много обрашений лишних к листам. Пробуйте следущий код с использованием массива данных, незнаю как на больших объёмах будет работать. Но думаю что быстрее первоначального кода.

[vba]

Код

Option Explicit

Sub Submit()
    Dim wsExport    As Worksheet
    Set wsExport = ThisWorkbook.Worksheets("Export")

    Dim wsGrids     As Worksheet
    Set wsGrids = ThisWorkbook.Worksheets("Grids")

    Dim acitivitySlicer As SlicerCache
    Set acitivitySlicer = ThisWorkbook.SlicerCaches("Slicer_Activity1")

    Dim guidelineSlicer As SlicerCache
    Set guidelineSlicer = ThisWorkbook.SlicerCaches("Slicer_Guideline1")

    Dim Last_Export_Raw As Long
    Last_Export_Raw = wsExport.Cells(Rows.Count, 1).End(xlUp).Row + 1

    Dim Last_Attribute As Long
    Last_Attribute = Application.CountA(wsGrids.Range("A18:A" & wsGrids.Cells(wsGrids.Rows.Count, 1).End(xlUp).Row))
    Application.ScreenUpdating = False

    Dim dataArray   As Variant
    dataArray = Array( _
            acitivitySlicer.VisibleSlicerItems(1).Caption, _
            guidelineSlicer.VisibleSlicerItems(1).Caption, _
            wsGrids.Range("B8").Value, _
            wsGrids.Range("B3").Value, _
            wsGrids.Range("B4").Value, _
            wsGrids.Range("B4").Value, _
            wsGrids.Range("B5").Value, _
            wsGrids.Range("B6").Value, _
            wsGrids.Range("B11").Value, _
            "GE-GE-1000659474", _
            wsGrids.Range("B9").Value, _
            wsGrids.Range("B10").Value, _
            wsGrids.Range("B12").Value, _
            wsGrids.Range("B13").Value, _
            "", _
            wsGrids.Range("C4").Value, _
            wsGrids.Range("C6").Value, _
            wsGrids.Range("N55").Value, _
            "", "", "", "", "" _
            )

    wsExport.Range("A" & Last_Export_Raw & ":W" & Last_Export_Raw).Value = dataArray

    wsExport.Range("X" & Last_Export_Raw & ":X" & Last_Export_Raw + Last_Attribute - 1).Value = wsGrids.Range("A18:A" & 17 + Last_Attribute).Value
    wsExport.Range("Y" & Last_Export_Raw & ":Y" & Last_Export_Raw + Last_Attribute - 1).Value = wsGrids.Range("O18:O" & 17 + Last_Attribute).Value
    wsExport.Range("Z" & Last_Export_Raw & ":Z" & Last_Export_Raw + Last_Attribute - 1).Value = wsGrids.Range("B18:B" & 17 + Last_Attribute).Value
    wsExport.Range("AA" & Last_Export_Raw & ":AA" & Last_Export_Raw + Last_Attribute - 1).Value = wsGrids.Range("L18:L" & 17 + Last_Attribute).Value
    wsExport.Range("AB" & Last_Export_Raw & ":AB" & Last_Export_Raw + Last_Attribute - 1).Value = wsGrids.Range("M18:M" & 17 + Last_Attribute).Value

    Dim Last_Chapter As Long
    Last_Chapter = wsExport.Cells(Rows.Count, 24).End(xlUp).Row
    wsExport.Range("A" & Last_Export_Raw & ":W" & Last_Export_Raw).Copy
    wsExport.Range("A" & Last_Export_Raw + 1 & ":W" & Last_Chapter).PasteSpecial xlPasteValues

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

[/vba]

Может кто ещё оптимальнее напишит код. Удачи.

[vba]

Код

[/vba]

Может кто ещё оптимальнее напишит код. Удачи.MikeVol

Ученик.
Одесса - Украина

Ответить

СообщениеEgyptian, Доброго времени суток. У вас много обрашений лишних к листам. Пробуйте следущий код с использованием массива данных, незнаю как на больших объёмах будет работать. Но думаю что быстрее первоначального кода.

[vba]

Код

[/vba]

Может кто ещё оптимальнее напишит код. Удачи.

Автор - MikeVol
Дата добавления - 21.02.2025 в 16:39

Egyptian

Дата: Понедельник, 24.02.2025, 20:40 | Сообщение № 3

Группа: Проверенные

Ранг: Ветеран

Сообщений: 530

Репутация: 193 ±

Замечаний: 0% ±

Excel 2013/2016

MikeVol, Николай, извиняюсь, за долгий ответ. Ваш код прекрасно работает. Субъективно быстрее того, что есть. Я даже смог кое-что в него добавить. Спасибо большое и плюсик в карму!

Ответить

Экспорт данных из одной книги в другую (Макросы/Sub)

Страница 1 из 1
1